diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 7bba9d7332..fcafe3441c 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -76,8 +76,8 @@ $nl { $examples "Here is a typical usage of " { $link add-library } ":" { $code "<< \"freetype\" {" - " { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" - " { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" + " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" + " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" " { [ t ] [ drop ] }" "} cond >>" } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index cfa9fb2e16..2f82e5db98 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -29,7 +29,7 @@ M: f expired? drop t ; f { simple-c-ptr } declare ; inline : alien>native-string ( alien -- string ) - windows? [ alien>u16-string ] [ alien>char-string ] if ; + os windows? [ alien>u16-string ] [ alien>char-string ] if ; : dll-path ( dll -- string ) (dll-path) alien>native-string ; @@ -62,22 +62,16 @@ TUPLE: library path abi dll ; : add-library ( name path abi -- ) swap libraries get set-at ; -TUPLE: alien-callback return parameters abi quot xt ; - ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) alien-callback-error ; -TUPLE: alien-indirect return parameters abi ; - ERROR: alien-indirect-error ; : alien-indirect ( ... funcptr return parameters abi -- ) alien-indirect-error ; -TUPLE: alien-invoke library function return parameters abi ; - ERROR: alien-invoke-error library symbol ; : alien-invoke ( ... return library function parameters -- ... ) diff --git a/core/alien/arrays/arrays.factor b/core/alien/arrays/arrays.factor index c9b9d838dd..402b01550b 100644 --- a/core/alien/arrays/arrays.factor +++ b/core/alien/arrays/arrays.factor @@ -25,7 +25,7 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; -M: value-type c-type-reg-class drop T{ int-regs } ; +M: value-type c-type-reg-class drop int-regs ; M: value-type c-type-prep drop f ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index ae99f9e6bf..508fcd61a6 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -4,7 +4,8 @@ USING: bit-arrays byte-arrays float-arrays arrays generator.registers 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 ; +layouts system compiler.units io.files io.encodings.binary +accessors combinators ; IN: alien.c-types DEFER: @@ -17,8 +18,12 @@ boxer prep unboxer getter setter reg-class size align stack-align? ; +: construct-c-type ( class -- type ) + construct-empty + int-regs >>reg-class ; + : ( -- type ) - T{ int-regs } { set-c-type-reg-class } \ c-type construct ; + \ c-type construct-c-type ; SYMBOL: c-types @@ -181,10 +186,10 @@ DEFER: >c-ushort-array : define-c-type ( type name vocab -- ) >r tuck typedef r> [ define-nth ] 2keep define-set-nth ; -TUPLE: long-long-type ; +TUPLE: long-long-type < c-type ; -: ( type -- type ) - long-long-type construct-delegate ; +: ( -- type ) + long-long-type construct-c-type ; M: long-long-type unbox-parameter ( n type -- ) c-type-unboxer %unbox-long-long ; @@ -235,22 +240,15 @@ M: long-long-type box-return ( type -- ) : define-from-array ( type vocab -- ) [ from-array-word ] 2keep c-array>quot define ; -: ( getter setter width boxer unboxer -- type ) - - [ set-c-type-unboxer ] keep - [ set-c-type-boxer ] keep - [ set-c-type-size ] 2keep - [ set-c-type-align ] keep - [ set-c-type-setter ] keep - [ set-c-type-getter ] keep ; - : define-primitive-type ( type name -- ) "alien.c-types" - [ define-c-type ] 2keep - [ define-deref ] 2keep - [ define-to-array ] 2keep - [ define-from-array ] 2keep - define-out ; + { + [ define-c-type ] + [ define-deref ] + [ define-to-array ] + [ define-from-array ] + [ define-out ] + } 2cleave ; : expand-constants ( c-type -- c-type' ) #! We use word-def call instead of execute to get around @@ -264,130 +262,157 @@ M: long-long-type box-return ( type -- ) binary file-contents dup malloc-byte-array swap length ; [ - [ alien-cell ] - [ set-alien-cell ] - bootstrap-cell - "box_alien" - "alien_offset" + + [ alien-cell ] >>getter + [ set-alien-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + "box_alien" >>boxer + "alien_offset" >>unboxer "void*" define-primitive-type - [ alien-signed-8 ] - [ set-alien-signed-8 ] - 8 - "box_signed_8" - "to_signed_8" + + [ alien-signed-8 ] >>getter + [ set-alien-signed-8 ] >>setter + 8 >>size + 8 >>align + "box_signed_8" >>boxer + "to_signed_8" >>unboxer "longlong" define-primitive-type - [ alien-unsigned-8 ] - [ set-alien-unsigned-8 ] - 8 - "box_unsigned_8" - "to_unsigned_8" + + [ alien-unsigned-8 ] >>getter + [ set-alien-unsigned-8 ] >>setter + 8 >>size + 8 >>align + "box_unsigned_8" >>boxer + "to_unsigned_8" >>unboxer "ulonglong" define-primitive-type - [ alien-signed-cell ] - [ set-alien-signed-cell ] - bootstrap-cell - "box_signed_cell" - "to_fixnum" + + [ alien-signed-cell ] >>getter + [ set-alien-signed-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + "box_signed_cell" >>boxer + "to_fixnum" >>unboxer "long" define-primitive-type - [ alien-unsigned-cell ] - [ set-alien-unsigned-cell ] - bootstrap-cell - "box_unsigned_cell" - "to_cell" + + [ alien-unsigned-cell ] >>getter + [ set-alien-unsigned-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + "box_unsigned_cell" >>boxer + "to_cell" >>unboxer "ulong" define-primitive-type - [ alien-signed-4 ] - [ set-alien-signed-4 ] - 4 - "box_signed_4" - "to_fixnum" + + [ alien-signed-4 ] >>getter + [ set-alien-signed-4 ] >>setter + 4 >>size + 4 >>align + "box_signed_4" >>boxer + "to_fixnum" >>unboxer "int" define-primitive-type - [ alien-unsigned-4 ] - [ set-alien-unsigned-4 ] - 4 - "box_unsigned_4" - "to_cell" + + [ alien-unsigned-4 ] >>getter + [ set-alien-unsigned-4 ] >>setter + 4 >>size + 4 >>align + "box_unsigned_4" >>boxer + "to_cell" >>unboxer "uint" define-primitive-type - [ alien-signed-2 ] - [ set-alien-signed-2 ] - 2 - "box_signed_2" - "to_fixnum" + + [ alien-signed-2 ] >>getter + [ set-alien-signed-2 ] >>setter + 2 >>size + 2 >>align + "box_signed_2" >>boxer + "to_fixnum" >>unboxer "short" define-primitive-type - [ alien-unsigned-2 ] - [ set-alien-unsigned-2 ] - 2 - "box_unsigned_2" - "to_cell" + + [ alien-unsigned-2 ] >>getter + [ set-alien-unsigned-2 ] >>setter + 2 >>size + 2 >>align + "box_unsigned_2" >>boxer + "to_cell" >>unboxer "ushort" define-primitive-type - [ alien-signed-1 ] - [ set-alien-signed-1 ] - 1 - "box_signed_1" - "to_fixnum" + + [ alien-signed-1 ] >>getter + [ set-alien-signed-1 ] >>setter + 1 >>size + 1 >>align + "box_signed_1" >>boxer + "to_fixnum" >>unboxer "char" define-primitive-type - [ alien-unsigned-1 ] - [ set-alien-unsigned-1 ] - 1 - "box_unsigned_1" - "to_cell" + + [ alien-unsigned-1 ] >>getter + [ set-alien-unsigned-1 ] >>setter + 1 >>size + 1 >>align + "box_unsigned_1" >>boxer + "to_cell" >>unboxer "uchar" define-primitive-type - [ alien-unsigned-4 zero? not ] - [ 1 0 ? set-alien-unsigned-4 ] - 4 - "box_boolean" - "to_boolean" + + [ alien-unsigned-4 zero? not ] >>getter + [ 1 0 ? set-alien-unsigned-4 ] >>setter + 4 >>size + 4 >>align + "box_boolean" >>boxer + "to_boolean" >>unboxer "bool" define-primitive-type - [ alien-float ] - [ >r >r >float r> r> set-alien-float ] - 4 - "box_float" - "to_float" + + [ alien-float ] >>getter + [ >r >r >float r> r> set-alien-float ] >>setter + 4 >>size + 4 >>align + "box_float" >>boxer + "to_float" >>unboxer + single-float-regs >>reg-class + [ >float ] >>prep "float" define-primitive-type - T{ float-regs f 4 } "float" c-type set-c-type-reg-class - [ >float ] "float" c-type set-c-type-prep - - [ alien-double ] - [ >r >r >float r> r> set-alien-double ] - 8 - "box_double" - "to_double" + + [ alien-double ] >>getter + [ >r >r >float r> r> set-alien-double ] >>setter + 8 >>size + 8 >>align + "box_double" >>boxer + "to_double" >>unboxer + double-float-regs >>reg-class + [ >float ] >>prep "double" define-primitive-type - T{ float-regs f 8 } "double" c-type set-c-type-reg-class - [ >float ] "double" c-type set-c-type-prep - - [ alien-cell alien>char-string ] - [ set-alien-cell ] - bootstrap-cell - "box_char_string" - "alien_offset" + + [ alien-cell alien>char-string ] >>getter + [ set-alien-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + "box_char_string" >>boxer + "alien_offset" >>unboxer + [ string>char-alien ] >>prep "char*" define-primitive-type "char*" "uchar*" typedef - [ string>char-alien ] "char*" c-type set-c-type-prep - - [ alien-cell alien>u16-string ] - [ set-alien-cell ] - 4 - "box_u16_string" - "alien_offset" + + [ alien-cell alien>u16-string ] >>getter + [ set-alien-cell ] >>setter + 4 >>size + 4 >>align + "box_u16_string" >>boxer + "alien_offset" >>unboxer + [ string>u16-alien ] >>prep "ushort*" define-primitive-type - [ string>u16-alien ] "ushort*" c-type set-c-type-prep - - win64? "longlong" "long" ? "ptrdiff_t" typedef - + os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef ] with-compilation-unit diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 1a9d5b5392..0f74f52d60 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -9,6 +9,14 @@ kernel.private threads continuations.private libc combinators compiler.errors continuations layouts accessors ; IN: alien.compiler +TUPLE: #alien-node < node return parameters abi ; + +TUPLE: #alien-callback < #alien-node quot xt ; + +TUPLE: #alien-indirect < #alien-node ; + +TUPLE: #alien-invoke < #alien-node library function ; + : large-struct? ( ctype -- ? ) dup c-struct? [ heap-size struct-small-enough? not @@ -62,29 +70,36 @@ GENERIC: reg-size ( register-class -- n ) M: int-regs reg-size drop cell ; -M: float-regs reg-size float-regs-size ; +M: single-float-regs reg-size drop 4 ; + +M: double-float-regs reg-size drop 8 ; + +GENERIC: reg-class-variable ( register-class -- symbol ) + +M: reg-class reg-class-variable ; + +M: float-regs reg-class-variable drop float-regs ; GENERIC: inc-reg-class ( register-class -- ) -: (inc-reg-class) - dup class inc +M: reg-class inc-reg-class + dup reg-class-variable inc fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; -M: int-regs inc-reg-class - (inc-reg-class) ; - M: float-regs inc-reg-class - dup (inc-reg-class) + dup call-next-method fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ; : reg-class-full? ( class -- ? ) - dup class get swap param-regs length >= ; + [ reg-class-variable get ] [ param-regs length ] bi >= ; : spill-param ( reg-class -- n reg-class ) - reg-size stack-params dup get -rot +@ T{ stack-params } ; + stack-params get + >r reg-size stack-params +@ r> + stack-params ; : fastcall-param ( reg-class -- n reg-class ) - [ dup class get swap inc-reg-class ] keep ; + [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ; : alloc-parameter ( parameter -- reg reg-class ) c-type-reg-class dup reg-class-full? @@ -229,32 +244,32 @@ M: no-such-symbol compiler-error-type ] if ; : alien-invoke-dlsym ( node -- symbols dll ) - dup alien-invoke-function dup pick stdcall-mangle 2array - swap alien-invoke-library library dup [ library-dll ] when + dup function>> dup pick stdcall-mangle 2array + swap library>> library dup [ dll>> ] when 2dup check-dlsym ; \ alien-invoke [ ! Four literals 4 ensure-values - \ alien-invoke empty-node + #alien-invoke construct-empty ! Compile-time parameters - pop-parameters over set-alien-invoke-parameters - pop-literal nip over set-alien-invoke-function - pop-literal nip over set-alien-invoke-library - pop-literal nip over set-alien-invoke-return + pop-parameters >>parameters + pop-literal nip >>function + pop-literal nip >>library + pop-literal nip >>return ! Quotation which coerces parameters to required types dup make-prep-quot recursive-state get infer-quot ! Set ABI - dup alien-invoke-library - library [ library-abi ] [ "cdecl" ] if* - over set-alien-invoke-abi + dup library>> + library [ abi>> ] [ "cdecl" ] if* + >>abi ! Add node to IR dup node, ! Magic #: consume exactly the number of inputs 0 alien-invoke-stack ] "infer" set-word-prop -M: alien-invoke generate-node +M: #alien-invoke generate-node dup alien-invoke-frame [ end-basic-block %prepare-alien-invoke @@ -273,11 +288,11 @@ M: alien-indirect-error summary ! Three literals and function pointer 4 ensure-values 4 reify-curries - \ alien-indirect empty-node + #alien-indirect construct-empty ! Compile-time parameters - pop-literal nip over set-alien-indirect-abi - pop-parameters over set-alien-indirect-parameters - pop-literal nip over set-alien-indirect-return + pop-literal nip >>abi + pop-parameters >>parameters + pop-literal nip >>return ! Quotation which coerces parameters to required types dup make-prep-quot [ dip ] curry recursive-state get infer-quot ! Add node to IR @@ -286,7 +301,7 @@ M: alien-indirect-error summary 1 alien-invoke-stack ] "infer" set-word-prop -M: alien-indirect generate-node +M: #alien-indirect generate-node dup alien-invoke-frame [ ! Flush registers end-basic-block @@ -315,17 +330,17 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; : callback-bottom ( node -- ) - alien-callback-xt [ word-xt drop ] curry + xt>> [ word-xt drop ] curry recursive-state get infer-quot ; \ alien-callback [ 4 ensure-values - \ alien-callback empty-node dup node, - pop-literal nip over set-alien-callback-quot - pop-literal nip over set-alien-callback-abi - pop-parameters over set-alien-callback-parameters - pop-literal nip over set-alien-callback-return - gensym dup register-callback over set-alien-callback-xt + #alien-callback construct-empty dup node, + pop-literal nip >>quot + pop-literal nip >>abi + pop-parameters >>parameters + pop-literal nip >>return + gensym dup register-callback >>xt callback-bottom ] "infer" set-word-prop @@ -365,8 +380,7 @@ TUPLE: callback-context ; : wrap-callback-quot ( node -- quot ) [ - dup alien-callback-quot - swap prepare-callback-return append , + [ quot>> ] [ prepare-callback-return ] bi append , [ callback-context construct-empty do-callback ] % ] [ ] make ; @@ -387,7 +401,7 @@ TUPLE: callback-context ; callback-unwind %unwind ; : generate-callback ( node -- ) - dup alien-callback-xt dup [ + dup xt>> dup [ init-templates %save-word-xt %prologue-later @@ -398,5 +412,5 @@ TUPLE: callback-context ; ] with-stack-frame ] with-generator ; -M: alien-callback generate-node +M: #alien-callback generate-node end-basic-block generate-callback iterate-next ; diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index b6326e1c10..e85789a4f2 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -16,6 +16,22 @@ $nl "To make an assoc into an alist:" { $subsection >alist } ; +ARTICLE: "enums" "Enumerations" +"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:" +{ $subsection enum } +{ $subsection } +"Inverting a permutation using enumerations:" +{ $example "USING: assocs sorting prettyprint ;" ": invert >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ; + +HELP: enum +{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence." +$nl +"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ; + +HELP: +{ $values { "seq" sequence } { "enum" enum } } +{ $description "Creates a new enumeration." } ; + ARTICLE: "assocs-protocol" "Associative mapping protocol" "All associative mappings must be instances of a mixin class:" { $subsection assoc } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index b911faf672..6b6bd3d51a 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2007 Daniel Ehrenberg +! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences arrays math sequences.private vectors ; +USING: kernel sequences arrays math sequences.private vectors +accessors ; IN: assocs MIXIN: assoc @@ -189,3 +190,24 @@ M: f clear-assoc drop ; M: f assoc-like drop dup assoc-empty? [ drop f ] when ; INSTANCE: sequence assoc + +TUPLE: enum seq ; + +C: enum + +M: enum at* + seq>> 2dup bounds-check? + [ nth t ] [ 2drop f f ] if ; + +M: enum set-at seq>> set-nth ; + +M: enum delete-at enum-seq delete-nth ; + +M: enum >alist ( enum -- alist ) + seq>> [ length ] keep 2array flip ; + +M: enum assoc-size seq>> length ; + +M: enum clear-assoc seq>> delete-all ; + +INSTANCE: enum assoc diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 7d4db3c473..618c62f332 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -14,13 +14,7 @@ IN: bootstrap.compiler "alien.remote-control" require ] unless -"cpu." cpu append require - -: enable-compiler ( -- ) - [ optimized-recompile-hook ] recompile-hook set-global ; - -: disable-compiler ( -- ) - [ default-recompile-hook ] recompile-hook set-global ; +"cpu." cpu word-name append require enable-compiler @@ -43,8 +37,6 @@ nl wrap probe - delegate - underlying find-pair-next namestack* diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index fc963683b6..05d48af2e8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -4,15 +4,16 @@ 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.tuple classes.tuple.private -words.private io.binary io.files vocabs vocabs.loader -source-files definitions debugger float-arrays +splitting growable classes classes.builtin classes.tuple +classes.tuple.private words.private io.binary io.files vocabs +vocabs.loader source-files definitions debugger float-arrays quotations.private sequences.private combinators io.encodings.binary ; IN: bootstrap.image : my-arch ( -- arch ) - cpu dup "ppc" = [ >r os "-" r> 3append ] when ; + cpu word-name + dup "ppc" = [ >r os word-name "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 846cce153b..ceb011d52b 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel alien byte-arrays hashtables vectors strings sbufs arrays bit-arrays -float-arrays quotations assocs layouts classes.tuple.private ; +float-arrays quotations assocs layouts classes.tuple.private +kernel.private ; BIN: 111 tag-mask set 8 num-tags set @@ -15,6 +16,7 @@ H{ { bignum BIN: 001 } { tuple BIN: 010 } { object BIN: 011 } + { hi-tag BIN: 011 } { ratio BIN: 100 } { float BIN: 101 } { complex BIN: 110 } diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index bc876c2dec..516ff7ed74 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -3,10 +3,10 @@ USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes -classes.tuple classes.tuple.private kernel.private vocabs -vocabs.loader source-files definitions slots.deprecated -classes.union compiler.units bootstrap.image.private io.files -accessors combinators ; +classes.builtin classes.tuple classes.tuple.private +kernel.private vocabs vocabs.loader source-files definitions +slots.deprecated classes.union compiler.units +bootstrap.image.private io.files accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -31,6 +31,7 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set +H{ } clone forgotten-definitions set H{ } clone root-cache set H{ } clone source-files set H{ } clone update-map set @@ -101,17 +102,24 @@ num-types get f builtins set } [ create-vocab drop ] each ! Builtin classes -: builtin-predicate-quot ( class -- quot ) +: lo-tag-eq-quot ( n -- quot ) + [ \ tag , , \ eq? , ] [ ] make ; + +: hi-tag-eq-quot ( n -- quot ) [ - "type" word-prop - [ tag-mask get < \ tag \ type ? , ] [ , ] bi - \ eq? , + [ dup tag ] % \ hi-tag tag-number , \ eq? , + [ [ hi-tag ] % , \ eq? , ] [ ] make , + [ drop f ] , + \ if , ] [ ] make ; +: builtin-predicate-quot ( class -- quot ) + "type" word-prop + dup tag-mask get < + [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ; + : define-builtin-predicate ( class -- ) - [ dup builtin-predicate-quot define-predicate ] - [ predicate-word make-inline ] - bi ; + dup builtin-predicate-quot define-predicate ; : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; @@ -119,27 +127,56 @@ num-types get f builtins set : register-builtin ( class -- ) [ dup lookup-type-number "type" set-word-prop ] [ dup "type" word-prop builtins get set-nth ] - bi ; + [ f f builtin-class define-class ] + tri ; : define-builtin-slots ( symbol slotspec -- ) [ drop ] [ 1 simple-slots ] 2bi [ "slots" set-word-prop ] [ define-slots ] 2bi ; : define-builtin ( symbol slotspec -- ) - >r - { - [ register-builtin ] - [ f f builtin-class define-class ] - [ define-builtin-predicate ] - [ ] - } cleave + >r [ define-builtin-predicate ] keep r> define-builtin-slots ; -! Forward definitions -"object" "kernel" create t "class" set-word-prop -"object" "kernel" create union-class "metaclass" set-word-prop +"fixnum" "math" create register-builtin +"bignum" "math" create register-builtin +"tuple" "kernel" create register-builtin +"ratio" "math" create register-builtin +"float" "math" create register-builtin +"complex" "math" create register-builtin +"f" "syntax" lookup register-builtin +"array" "arrays" create register-builtin +"wrapper" "kernel" create register-builtin +"float-array" "float-arrays" create register-builtin +"callstack" "kernel" create register-builtin +"string" "strings" create register-builtin +"bit-array" "bit-arrays" create register-builtin +"quotation" "quotations" create register-builtin +"dll" "alien" create register-builtin +"alien" "alien" create register-builtin +"word" "words" create register-builtin +"byte-array" "byte-arrays" create register-builtin +"tuple-layout" "classes.tuple.private" create register-builtin -"null" "kernel" create drop +! Catch-all class for providing a default method. +"object" "kernel" create +[ f builtins get [ ] subset union-class define-class ] +[ [ drop t ] "predicate" set-word-prop ] +bi + +"object?" "kernel" vocab-words delete-at + +! Class of objects with object tag +"hi-tag" "kernel.private" create +builtins get num-tags get tail define-union-class + +! Empty class with no instances +"null" "kernel" create +[ f { } union-class define-class ] +[ [ drop f ] "predicate" set-word-prop ] +bi + +"null?" "kernel" vocab-words delete-at "fixnum" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop @@ -328,47 +365,28 @@ define-builtin } } define-builtin -"tuple" "kernel" create { } define-builtin - -"tuple" "kernel" lookup -{ - { - { "object" "kernel" } - "delegate" - { "delegate" "kernel" } - { "set-delegate" "kernel" } - } -} -[ drop ] [ generate-tuple-slots ] 2bi -[ [ name>> ] map "slot-names" set-word-prop ] -[ "slots" set-word-prop ] -[ define-slots ] 2tri - -"tuple" "kernel" lookup define-tuple-layout - -! Define general-t type, which is any object that is not f. -"general-t" "kernel" create -f "f" "syntax" lookup builtins get remove [ ] subset union-class -define-class +"tuple" "kernel" create { + [ { } define-builtin ] + [ { "delegate" } "slot-names" set-word-prop ] + [ define-tuple-layout ] + [ + { + { + { "object" "kernel" } + "delegate" + { "delegate" "kernel" } + { "set-delegate" "kernel" } + } + } + [ drop ] [ generate-tuple-slots ] 2bi + [ "slots" set-word-prop ] + [ define-slots ] + 2bi + ] +} cleave "f" "syntax" create [ not ] "predicate" set-word-prop -"f?" "syntax" create "syntax" vocab-words delete-at - -"general-t" "kernel" create [ ] "predicate" set-word-prop -"general-t?" "kernel" create "syntax" vocab-words delete-at - -! Catch-all class for providing a default method. -"object" "kernel" create [ drop t ] "predicate" set-word-prop -"object" "kernel" create -f builtins get [ ] subset union-class define-class - -! Class of objects with object tag -"hi-tag" "classes.private" create -f builtins get num-tags get tail union-class define-class - -! Null class with no instances. -"null" "kernel" create [ drop f ] "predicate" set-word-prop -"null" "kernel" create f { } union-class define-class +"f?" "syntax" vocab-words delete-at ! Create special tombstone values "tombstone" "hashtables.private" create @@ -638,7 +656,6 @@ f builtins get num-tags get tail union-class define-class { "code-room" "memory" } { "os-env" "system" } { "millis" "system" } - { "type" "kernel.private" } { "tag" "kernel.private" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } @@ -710,7 +727,6 @@ f builtins get num-tags get tail union-class define-class { "(sleep)" "threads.private" } { "" "float-arrays" } { "" "classes.tuple.private" } - { "class-hash" "kernel.private" } { "callstack>array" "kernel" } { "innermost-frame-quot" "kernel.private" } { "innermost-frame-scan" "kernel.private" } diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 34f758c9df..f99c8eb82f 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ; ! Rehash hashtables, since bootstrap.image creates them ! using the host image's hashing algorithms [ hashtable? ] instances [ rehash ] each - boot ] % diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index bbb2e44843..c82ebbe9f8 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -11,7 +11,7 @@ IN: bootstrap.stage2 SYMBOL: bootstrap-time : default-image-name ( -- string ) - vm file-name windows? [ "." split1 drop ] when + vm file-name os windows? [ "." split1 drop ] when ".image" append resource-path ; : do-crossref ( -- ) @@ -65,8 +65,8 @@ parse-command-line "-no-crossref" cli-args member? [ do-crossref ] unless ! Set dll paths -wince? [ "windows.ce" require ] when -winnt? [ "windows.nt" require ] when +os wince? [ "windows.ce" require ] when +os winnt? [ "windows.nt" require ] when "deploy-vocab" get [ "stage2: deployment mode" print diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index e7e90d8dd0..4d5f31dc82 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -43,6 +43,7 @@ IN: bootstrap.syntax "PRIMITIVE:" "PRIVATE>" "SBUF\"" + "SINGLETON:" "SYMBOL:" "TUPLE:" "T{" @@ -66,6 +67,7 @@ IN: bootstrap.syntax "CS{" "<<" ">>" + "call-next-method" } [ "syntax" create drop ] each "t" "syntax" lookup define-symbol diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index cdf817e31d..d61b62af3b 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units growable -random inference effects ; +random inference effects kernel.private ; : class= [ class< ] 2keep swap class< and ; @@ -23,8 +23,8 @@ random inference effects ; [ t ] [ number object number class-and* ] unit-test [ t ] [ object number number class-and* ] unit-test [ t ] [ slice reversed null class-and* ] unit-test -[ t ] [ general-t \ f null class-and* ] unit-test -[ t ] [ general-t \ f object class-or* ] unit-test +[ t ] [ \ f class-not \ f null class-and* ] unit-test +[ t ] [ \ f class-not \ f object class-or* ] unit-test TUPLE: first-one ; TUPLE: second-one ; @@ -68,13 +68,13 @@ UNION: c a b ; [ t ] [ \ tuple-class \ class class< ] unit-test [ f ] [ \ class \ tuple-class class< ] unit-test -TUPLE: delegate-clone ; +TUPLE: tuple-example ; -[ t ] [ \ null \ delegate-clone class< ] unit-test -[ f ] [ \ object \ delegate-clone class< ] unit-test -[ f ] [ \ object \ delegate-clone class< ] unit-test -[ t ] [ \ delegate-clone \ tuple class< ] unit-test -[ f ] [ \ tuple \ delegate-clone class< ] unit-test +[ t ] [ \ null \ tuple-example class< ] unit-test +[ f ] [ \ object \ tuple-example class< ] unit-test +[ f ] [ \ object \ tuple-example class< ] unit-test +[ t ] [ \ tuple-example \ tuple class< ] unit-test +[ f ] [ \ tuple \ tuple-example class< ] unit-test TUPLE: a1 ; TUPLE: b1 ; @@ -96,7 +96,7 @@ UNION: z1 b1 c1 ; [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test -[ f ] [ growable hi-tag classes-intersect? ] unit-test +[ f ] [ growable \ hi-tag classes-intersect? ] unit-test [ t ] [ growable tuple sequence class-and class< diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 5d7c114cbc..4614e4c4ce 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes combinators accessors sequences arrays -vectors assocs namespaces words sorting layouts math hashtables -; +USING: kernel classes classes.builtin combinators accessors +sequences arrays vectors assocs namespaces words sorting layouts +math hashtables kernel.private ; IN: classes.algebra : 2cache ( key1 key2 assoc quot -- value ) @@ -103,7 +103,7 @@ C: anonymous-complement { { [ over tuple eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } - { [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] } + { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] } { [ t ] [ swap classes-intersect? ] } } cond ; @@ -211,12 +211,6 @@ C: anonymous-complement : flatten-class ( class -- assoc ) [ (flatten-class) ] H{ } make-assoc ; -: class-hashes ( class -- seq ) - flatten-class keys [ - dup builtin-class? - [ "type" word-prop ] [ hashcode ] if - ] map ; - : flatten-builtin-class ( class -- assoc ) flatten-class [ dup tuple class< [ 2drop tuple tuple ] when @@ -229,5 +223,5 @@ C: anonymous-complement : class-tags ( class -- tag/f ) class-types [ dup num-tags get >= - [ drop object tag-number ] when + [ drop \ hi-tag tag-number ] when ] map prune ; diff --git a/core/classes/builtin/builtin-docs.factor b/core/classes/builtin/builtin-docs.factor new file mode 100644 index 0000000000..6c5c262087 --- /dev/null +++ b/core/classes/builtin/builtin-docs.factor @@ -0,0 +1,28 @@ +USING: help.syntax help.markup classes layouts ; +IN: classes.builtin + +ARTICLE: "builtin-classes" "Built-in classes" +"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior." +$nl +"The set of built-in classes is a class:" +{ $subsection builtin-class } +{ $subsection builtin-class? } +"See " { $link "type-index" } " for a list of built-in classes." ; + +HELP: builtin-class +{ $class-description "The class of built-in classes." } +{ $examples + "The class of arrays is a built-in class:" + { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" } + "However, an instance of the array class is not a built-in class; it is not even a class:" + { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" } +} ; + +HELP: builtins +{ $var-description "Vector mapping type numbers to builtin class words." } ; + +HELP: type>class +{ $values { "n" "a non-negative integer" } { "class" class } } +{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." } +{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ; + diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor new file mode 100644 index 0000000000..1c2871b031 --- /dev/null +++ b/core/classes/builtin/builtin.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: classes words kernel kernel.private namespaces +sequences ; +IN: classes.builtin + +SYMBOL: builtins + +PREDICATE: builtin-class < class + "metaclass" word-prop builtin-class eq? ; + +: type>class ( n -- class ) builtins get-global nth ; + +: bootstrap-type>class ( n -- class ) builtins get nth ; + +M: hi-tag class hi-tag type>class ; + +M: object class tag type>class ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 9573de8949..dd3782e877 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -4,14 +4,6 @@ layouts classes.private classes.union classes.mixin classes.predicate quotations ; IN: classes -ARTICLE: "builtin-classes" "Built-in classes" -"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior." -$nl -"The set of built-in classes is a class:" -{ $subsection builtin-class } -{ $subsection builtin-class? } -"See " { $link "type-index" } " for a list of built-in classes." ; - ARTICLE: "class-predicates" "Class predicate words" "With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property." $nl @@ -21,7 +13,6 @@ $nl { { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } } { { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } } { { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } } - { { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } } } "The set of class predicate words is a class:" { $subsection predicate } @@ -39,16 +30,21 @@ $nl { $subsection class? } "You can ask an object for its class:" { $subsection class } +"Testing if an object is an instance of a class:" +{ $subsection instance? } "There is a universal class which all objects are an instance of, and an empty class with no instances:" { $subsection object } { $subsection null } "Obtaining a list of all defined classes:" { $subsection classes } -"Other sorts of classes:" +"There are several sorts of classes:" { $subsection "builtin-classes" } { $subsection "unions" } { $subsection "mixins" } { $subsection "predicates" } +{ $subsection "singletons" } +{ $link "tuples" } " are documented in their own section." +$nl "Classes can be inspected and operated upon:" { $subsection "class-operations" } { $see-also "class-index" } ; @@ -58,37 +54,20 @@ ABOUT: "classes" HELP: class { $values { "object" object } { "class" class } } { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." } -{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." } +{ $class-description "The class of all class words." } { $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ; HELP: classes { $values { "seq" "a sequence of class words" } } { $description "Finds all class words in the dictionary." } ; -HELP: builtin-class -{ $class-description "The class of built-in classes." } -{ $examples - "The class of arrays is a built-in class:" - { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" } - "However, an instance of the array class is not a built-in class; it is not even a class:" - { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" } -} ; - HELP: tuple-class { $class-description "The class of tuple class words." } { $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; -HELP: builtins -{ $var-description "Vector mapping type numbers to builtin class words." } ; - HELP: update-map { $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; -HELP: type>class -{ $values { "n" "a non-negative integer" } { "class" class } } -{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." } -{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ; - HELP: predicate-word { $values { "word" "a word" } { "predicate" "a predicate word" } } { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index ae9e6ec154..ae19f38d14 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files -compiler.units ; +compiler.units kernel.private ; IN: classes.tests ! DEFER: bah @@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 ! Test generic see and parsing [ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] [ [ \ bah see ] with-string-writer ] unit-test + +[ t ] [ 3 object instance? ] unit-test +[ t ] [ 3 fixnum instance? ] unit-test +[ f ] [ 3 float instance? ] unit-test +[ t ] [ 3 number instance? ] unit-test +[ f ] [ 3 null instance? ] unit-test +[ t ] [ "hi" \ hi-tag instance? ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index d6d1a72121..b22e21eb92 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -25,23 +25,16 @@ SYMBOL: class-or-cache class-and-cache get clear-assoc class-or-cache get clear-assoc ; -PREDICATE: class < word ( obj -- ? ) "class" word-prop ; - SYMBOL: update-map -SYMBOL: builtins -PREDICATE: builtin-class < class - "metaclass" word-prop builtin-class eq? ; +PREDICATE: class < word + "class" word-prop ; PREDICATE: tuple-class < class "metaclass" word-prop tuple-class eq? ; : classes ( -- seq ) all-words [ class? ] subset ; -: type>class ( n -- class ) builtins get-global nth ; - -: bootstrap-type>class ( n -- class ) builtins get nth ; - : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; @@ -58,7 +51,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ; dup class? [ "superclass" word-prop ] [ drop f ] if ; : superclasses ( class -- supers ) - [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ; + [ superclass ] follow reverse ; : members ( class -- seq ) #! Output f for non-classes to work with algebra code @@ -72,7 +65,7 @@ M: word reset-class drop ; ! update-map : class-uses ( class -- seq ) - dup members swap superclass [ suffix ] when* ; + [ members ] [ superclass ] bi [ suffix ] when* ; : class-usages ( class -- assoc ) [ update-map get at ] closure ; @@ -83,7 +76,7 @@ M: word reset-class drop ; : update-map- ( class -- ) dup class-uses update-map get remove-vertex ; -: define-class-props ( superclass members metaclass -- assoc ) +: make-class-props ( superclass members metaclass -- assoc ) [ [ dup [ bootstrap-word ] when "superclass" set ] [ [ bootstrap-word ] map "members" set ] @@ -92,12 +85,16 @@ M: word reset-class drop ; ] H{ } make-assoc ; : (define-class) ( word props -- ) - over reset-class - over deferred? [ over define-symbol ] when - >r dup word-props r> union over set-word-props - dup predicate-word 2dup 1quotation "predicate" set-word-prop - over "predicating" set-word-prop - t "class" set-word-prop ; + >r + dup reset-class + dup deferred? [ dup define-symbol ] when + dup word-props + r> union over set-word-props + dup predicate-word + [ 1quotation "predicate" set-word-prop ] + [ swap "predicating" set-word-prop ] + [ drop t "class" set-word-prop ] + 2tri ; PRIVATE> @@ -105,25 +102,24 @@ GENERIC: update-class ( class -- ) M: class update-class drop ; -: update-classes ( assoc -- ) - [ drop update-class ] assoc-each ; - GENERIC: update-methods ( assoc -- ) +: update-classes ( class -- ) + class-usages + [ [ drop update-class ] assoc-each ] + [ update-methods ] + bi ; + : define-class ( word superclass members metaclass -- ) #! If it was already a class, update methods after. reset-caches - define-class-props + make-class-props [ drop update-map- ] - [ (define-class) ] [ - drop - [ update-map+ ] [ - class-usages - [ update-classes ] - [ update-methods ] bi - ] bi - ] 2tri ; + [ (define-class) ] + [ drop update-map+ ] + 2tri ; -GENERIC: class ( object -- class ) inline +GENERIC: class ( object -- class ) -M: object class type type>class ; +: instance? ( obj class -- ? ) + "predicate" word-prop call ; diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor index 1fa6f7bd83..82dec5cec0 100755 --- a/core/classes/mixin/mixin-docs.factor +++ b/core/classes/mixin/mixin-docs.factor @@ -1,16 +1,18 @@ USING: help.markup help.syntax help words compiler.units -classes ; +classes sequences ; IN: classes.mixin ARTICLE: "mixins" "Mixin classes" -"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, new classes can be made into instances of a mixin class after the original definition of the mixin." +"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, mixin classes have the additional property that they are " { $emphasis "open" } "; new classes can be added to the mixin after the original definition of the mixin." { $subsection POSTPONE: MIXIN: } { $subsection POSTPONE: INSTANCE: } { $subsection define-mixin-class } { $subsection add-mixin-instance } "The set of mixin classes is a class:" { $subsection mixin-class } -{ $subsection mixin-class? } ; +{ $subsection mixin-class? } +"Mixins are used to defines suites of behavior which are generally useful and can be applied to user-defined classes. For example, the " { $link immutable-sequence } " mixin can be used with user-defined sequences to make them immutable." +{ $see-also "unions" "tuple-subclassing" } ; HELP: mixin-class { $class-description "The class of mixin classes." } ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index b771aa8920..aefd522269 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -7,7 +7,7 @@ IN: classes.mixin PREDICATE: mixin-class < union-class "mixin" word-prop ; M: mixin-class reset-class - { "metaclass" "members" "mixin" } reset-props ; + { "class" "metaclass" "members" "mixin" } reset-props ; : redefine-mixin-class ( class members -- ) dupd define-union-class diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index b2a5a03bb4..4729a6dd5e 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -14,11 +14,19 @@ PREDICATE: predicate-class < class ] [ ] make ; : define-predicate-class ( class superclass definition -- ) - >r dupd f predicate-class define-class - r> dupd "predicate-definition" set-word-prop - dup predicate-quot define-predicate ; + [ drop f predicate-class define-class ] + [ nip "predicate-definition" set-word-prop ] + [ + 2drop + [ dup predicate-quot define-predicate ] + [ update-classes ] + bi + ] 3tri ; M: predicate-class reset-class { - "metaclass" "predicate-definition" "superclass" + "class" + "metaclass" + "predicate-definition" + "superclass" } reset-props ; diff --git a/extra/classes/singleton/authors.txt b/core/classes/singleton/authors.txt similarity index 100% rename from extra/classes/singleton/authors.txt rename to core/classes/singleton/authors.txt diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor new file mode 100644 index 0000000000..a8dae809ec --- /dev/null +++ b/core/classes/singleton/singleton-docs.factor @@ -0,0 +1,34 @@ +USING: help.markup help.syntax kernel words ; +IN: classes.singleton + +ARTICLE: "singletons" "Singleton classes" +"A singleton is a class with only one instance and with no state." +{ $subsection POSTPONE: SINGLETON: } +{ $subsection define-singleton-class } +"The set of all singleton classes is itself a class:" +{ $subsection singleton-class? } +{ $subsection singleton-class } ; + +HELP: SINGLETON: +{ $syntax "SINGLETON: class" } +{ $values + { "class" "a new singleton to define" } +} +{ $description + "Defines a new singleton class. The class word itself is the sole instance of the singleton class." +} +{ $examples + { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } +} ; + +HELP: define-singleton-class +{ $values { "word" "a new word" } } +{ $description + "Defines a singleton class. This is the run-time equivalent of " { $link POSTPONE: SINGLETON: } "." } ; + +{ POSTPONE: SINGLETON: define-singleton-class } related-words + +HELP: singleton-class +{ $class-description "The class of singleton classes." } ; + +ABOUT: "singletons" diff --git a/extra/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor similarity index 64% rename from extra/classes/singleton/singleton-tests.factor rename to core/classes/singleton/singleton-tests.factor index 08f4a77aad..2ed51abb93 100644 --- a/extra/classes/singleton/singleton-tests.factor +++ b/core/classes/singleton/singleton-tests.factor @@ -4,9 +4,9 @@ IN: classes.singleton.tests [ ] [ SINGLETON: bzzt ] unit-test [ t ] [ bzzt bzzt? ] unit-test [ t ] [ bzzt bzzt eq? ] unit-test -GENERIC: zammo ( obj -- ) +GENERIC: zammo ( obj -- str ) [ ] [ M: bzzt zammo drop "yes!" ; ] unit-test [ "yes!" ] [ bzzt zammo ] unit-test [ ] [ SINGLETON: omg ] unit-test -[ t ] [ omg singleton? ] unit-test -[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test +[ t ] [ omg singleton-class? ] unit-test +[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor new file mode 100755 index 0000000000..65d7422ed7 --- /dev/null +++ b/core/classes/singleton/singleton.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: classes.predicate kernel sequences words ; +IN: classes.singleton + +PREDICATE: singleton-class < predicate-class + [ "predicate-definition" word-prop ] + [ [ eq? ] curry ] bi sequence= ; + +: define-singleton-class ( word -- ) + \ word over [ eq? ] curry define-predicate-class ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 18c8143654..4ee72cdf83 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -3,14 +3,63 @@ classes.tuple.private classes slots quotations words arrays generic.standard sequences definitions compiler.units ; IN: classes.tuple -ARTICLE: "tuple-constructors" "Constructors" -"Tuples are created by calling one of two words:" +ARTICLE: "parametrized-constructors" "Parameterized constructors" +"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack." +$nl +"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:" +{ $code + "TUPLE: vehicle max-speed occupants ;" + "" + ": add-occupant ( person vehicle -- ) occupants>> push ;" + "" + "TUPLE: car < vehicle engine ;" + ": ( max-speed engine -- car )" + " car construct-empty" + " V{ } clone >>occupants" + " swap >>engine" + " swap >>max-speed ;" + "" + "TUPLE: aeroplane < vehicle max-altitude ;" + ": ( max-speed max-altitude -- aeroplane )" + " aeroplane construct-empty" + " V{ } clone >>occupants" + " swap >>max-altitude" + " swap >>max-speed ;" +} +"The two constructors depend on the implementation of " { $snippet "vehicle" } " because they are responsible for initializing the " { $snippet "occupants" } " slot to an empty vector. If this slot is changed to contain a hashtable instead, there will be two places instead of one. A better approach is to use a parametrized constructor for vehicles:" +{ $code + "TUPLE: vehicle max-speed occupants ;" + "" + ": add-occupant ( person vehicle -- ) occupants>> push ;" + "" + ": construct-vehicle ( class -- vehicle )" + " construct-empty" + " V{ } clone >>occupants ;" + "" + "TUPLE: car < vehicle engine ;" + ": ( max-speed engine -- car )" + " car construct-vehicle" + " swap >>engine" + " swap >>max-speed ;" + "" + "TUPLE: aeroplane < vehicle max-altitude ;" + ": ( max-speed max-altitude -- aeroplane )" + " aeroplane construct-vehicle" + " swap >>max-altitude" + " swap >>max-speed ;" +} +"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ; + +ARTICLE: "tuple-constructors" "Tuple constructors" +"Tuples are created by calling one of two constructor primitives:" { $subsection construct-empty } { $subsection construct-boa } -"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "" } "." -$nl "A shortcut for defining BOA constructors:" { $subsection POSTPONE: C: } +"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "" } "." +$nl +"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers." +$nl "Examples of constructors:" { $code "TUPLE: color red green blue alpha ;" @@ -22,29 +71,77 @@ $nl "" ": construct-empty ;" ": f f f f ; ! identical to above" +} +{ $subsection "parametrized-constructors" } ; + +ARTICLE: "tuple-inheritance-example" "Tuple subclassing example" +"Rectangles, parallelograms and circles are all shapes. We support two operations on shapes:" +{ $list + "Computing the area" + "Computing the perimiter" +} +"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimiter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:" +{ $code + "GENERIC: area ( shape -- n )" + "GENERIC: perimiter ( shape -- n )" + "" + "TUPLE: shape ;" + "" + "TUPLE: circle < shape radius ;" + "M: area circle radius>> sq pi * ;" + "M: perimiter circle radius>> 2 * pi * ;" + "" + "TUPLE: quad < shape width height" + "M: area quad [ width>> ] [ height>> ] bi * ;" + "" + "TUPLE: rectangle < quad ;" + "M: rectangle perimiter [ width>> 2 * ] [ height>> 2 * ] bi + ;" + "" + ": hypot ( a b -- c ) [ sq ] bi@ + sqrt ;" + "" + "TUPLE: parallelogram < quad skew ;" + "M: parallelogram perimiter" + " [ width>> 2 * ] [ [ height>> ] [ skew>> ] bi hypot 2 * ] bi + ;" } ; -ARTICLE: "tuple-delegation" "Tuple delegation" -"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown." -{ $subsection delegate } -{ $subsection set-delegate } -"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution." +ARTICLE: "tuple-inheritance-anti-example" "When not to use tuple subclassing" +"Tuple subclassing should only be used for " { $emphasis "is-a" } " relationships; for example, a car " { $emphasis "is a" } " vehicle, and a circle " { $emphasis "is a" } " shape." +{ $heading "Anti-pattern #1: subclassing for has-a" } +"Subclassing should not be used for " { $emphasis "has-a" } " relationships. For example, if a shape " { $emphasis "has a" } " color, then " { $snippet "shape" } " should not subclass " { $snippet "color" } ". Using tuple subclassing in inappropriate situations leads to code which is more brittle and less flexible than it should be." $nl -"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object." +"For example, suppose that " { $snippet "shape" } " inherits from " { $snippet "color" } ":" +{ $code + "TUPLE: color r g b ;" + "TUPLE: shape < color ... ;" +} +"Now, the implementation of " { $snippet "shape" } " depends on a specific representation of colors as RGB colors. If a new generic color protocol is devised which also allows HSB and YUV colors to be used, the shape class will not be able to take advantage of them without changes. A better approach is to store the color in a slot:" +{ $code + "TUPLE: rgb-color r g b ;" + "TUPLE: hsv-color h s v ;" + "..." + "TUPLE: shape color ... ;" +} +"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships." +{ $heading "Anti-pattern #2: subclassing for implementation sharing only" } +"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used." $nl -"A pair of words examine delegation chains:" -{ $subsection delegates } -{ $subsection is? } -"An example:" -{ $example - "TUPLE: ellipse center radius ;" - "TUPLE: colored color ;" - "{ 0 0 } 10 \"my-ellipse\" set" - "{ 1 0 0 } \"my-shape\" set" - "\"my-ellipse\" get \"my-shape\" get set-delegate" - "\"my-shape\" get dup color>> swap center>> .s" - "{ 0 0 }\n{ 1 0 0 }" -} ; +"There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "." +$nl +"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes." +{ $heading "Anti-pattern #3: subclassing to override a method definition" } +"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link construct-empty } ", " { $link construct-boa } ", or a custom parametrized constructor." +{ $see-also "parametrized-constructors" } ; + +ARTICLE: "tuple-subclassing" "Tuple subclassing" +"Tuple subclassing can be used to express natural relationships between classes at the language level. For example, every car " { $emphasis "is a" } " vehicle, so if the " { $snippet "car" } " class subclasses the " { $snippet "vehicle" } " class, it can " { $emphasis "inherit" } " the slots and methods of " { $snippet "vehicle" } "." +$nl +"To define one tuple class as a subclass of another, use the optional superclass parameter to " { $link POSTPONE: TUPLE: } ":" +{ $code + "TUPLE: subclass < superclass ... ;" +} +{ $subsection "tuple-inheritance-example" } +{ $subsection "tuple-inheritance-anti-example" } +{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ; ARTICLE: "tuple-introspection" "Tuple introspection" "In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way." @@ -119,7 +216,28 @@ ARTICLE: "tuple-examples" "Tuple examples" ": promote ( person -- person )" " [ 1.2 * ] change-salary" " [ next-position ] change-position ;" -} ; +} +"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ; + +ARTICLE: "tuple-redefinition" "Tuple redefinition" +"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses." +$nl +"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "." +$nl +"There are three ways to change the list of effective slots of a class:" +{ $list + "Adding or removing direct slots of the class" + "Adding or removing direct slots of a superclass of the class" + "Changing the inheritance hierarchy by redefining a class to have a different superclass" +} +"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:" +{ $list + "If any slots were removed, the values are removed from the instance and are lost forever." + { "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." } + "If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory." + "If the number or order of effective slots changes, any BOA constructors are recompiled." +} +"Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ; ARTICLE: "tuples" "Tuples" "Tuples are user-defined classes composed of named slots." @@ -132,35 +250,21 @@ $nl { $subsection "accessors" } "Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:" { $subsection "tuple-constructors" } -"Further topics:" -{ $subsection "tuple-delegation" } +"Expressing relationships through the object system:" +{ $subsection "tuple-subclassing" } +"Introspection:" { $subsection "tuple-introspection" } +"Tuple classes can be redefined; this updates existing instances:" +{ $subsection "tuple-redefinition" } "Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ; ABOUT: "tuples" -HELP: delegate -{ $values { "obj" object } { "delegate" object } } -{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." } -{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ; - -HELP: set-delegate -{ $values { "delegate" object } { "tuple" tuple } } -{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ; - HELP: tuple= { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } } { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } { $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ; -HELP: removed-slots -{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } } -{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ; - -HELP: forget-removed-slots -{ $values { "class" tuple-class } { "slots" "a sequence of strings" } } -{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ; - HELP: tuple { $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class." $nl @@ -187,7 +291,7 @@ $low-level-note ; HELP: tuple-slots { $values { "tuple" tuple } { "seq" sequence } } -{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ; +{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ; { tuple-slots tuple>array } related-words @@ -209,26 +313,16 @@ HELP: define-tuple-class { tuple-class define-tuple-class POSTPONE: TUPLE: } related-words -HELP: delegates -{ $values { "obj" object } { "seq" sequence } } -{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ; - -HELP: is? -{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } } -{ $description "Tests if the object or one of its delegates satisfies the predicate quotation." -$nl -"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ; - HELP: >tuple { $values { "seq" sequence } { "tuple" tuple } } -{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots." +{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots." $nl "If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." } { $errors "Throws an error if the first element of the sequence is not a tuple class word." } ; HELP: tuple>array ( tuple -- array ) { $values { "tuple" tuple } { "array" array } } -{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ; +{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ; HELP: ( layout -- tuple ) { $values { "layout" tuple-layout } { "tuple" tuple } } diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index db0e25f091..729997d3b2 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -16,25 +16,6 @@ TUPLE: rect x y w h ; [ t ] [ 10 20 30 40 dup clone 0 swap move = ] unit-test -GENERIC: delegation-test -M: object delegation-test drop 3 ; -TUPLE: quux-tuple ; -: quux-tuple construct-empty ; -M: quux-tuple delegation-test drop 4 ; -TUPLE: quuux-tuple ; -: { set-delegate } quuux-tuple construct ; - -[ 3 ] [ delegation-test ] unit-test - -GENERIC: delegation-test-2 -TUPLE: quux-tuple-2 ; -: quux-tuple-2 construct-empty ; -M: quux-tuple-2 delegation-test-2 drop 4 ; -TUPLE: quuux-tuple-2 ; -: { set-delegate } quuux-tuple-2 construct ; - -[ 4 ] [ delegation-test-2 ] unit-test - ! Make sure we handle tuple class redefinition TUPLE: redefinition-test ; @@ -62,13 +43,13 @@ C: point [ 200 ] [ "p" get y>> ] unit-test [ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -"p" get 300 ">>z" "accessors" lookup execute drop +[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test [ 4 ] [ "p" get tuple-size ] unit-test [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -"IN: classes.tuple.tests TUPLE: point z y ;" eval +[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test [ 3 ] [ "p" get tuple-size ] unit-test @@ -102,11 +83,6 @@ C: empty [ t ] [ hashcode fixnum? ] unit-test -TUPLE: delegate-clone ; - -[ T{ delegate-clone T{ empty f } } ] -[ T{ delegate-clone T{ empty f } } clone ] unit-test - ! Compiler regression [ t length ] [ object>> t eq? ] must-fail-with @@ -242,7 +218,7 @@ C: erg's-reshape-problem [ "IN: classes.tuple.tests SYMBOL: not-a-class C: not-a-class" eval -] [ [ no-tuple-class? ] is? ] must-fail-with +] [ error>> no-tuple-class? ] must-fail-with ! Inheritance TUPLE: computer cpu ram ; @@ -394,7 +370,9 @@ test-server-slot-values ! Reshape crash TUPLE: test1 a ; TUPLE: test2 < test1 b ; -T{ test2 f "a" "b" } "test" set +C: test2 + +"a" "b" "test" set : test-a/b [ "a" ] [ "test" get a>> ] unit-test @@ -509,3 +487,45 @@ USE: vocabs define-tuple-class ] with-compilation-unit ] unit-test + +[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with + +! Accessors not being forgotten... +[ [ ] ] [ + "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;" + + "forget-accessors-test" parse-stream +] unit-test + +[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test + +: accessor-exists? ( class name -- ? ) + >r "forget-accessors-test" "classes.tuple.tests" lookup r> + ">>" append "accessors" lookup method >boolean ; + +[ t ] [ "x" accessor-exists? ] unit-test +[ t ] [ "y" accessor-exists? ] unit-test +[ t ] [ "z" accessor-exists? ] unit-test + +[ [ ] ] [ + "IN: classes.tuple.tests GENERIC: forget-accessors-test" + + "forget-accessors-test" parse-stream +] unit-test + +[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test + +[ f ] [ "x" accessor-exists? ] unit-test +[ f ] [ "y" accessor-exists? ] unit-test +[ f ] [ "z" accessor-exists? ] unit-test + +TUPLE: another-forget-accessors-test ; + + +[ [ ] ] [ + "IN: classes.tuple.tests GENERIC: another-forget-accessors-test" + + "another-forget-accessors-test" parse-stream +] unit-test + +[ t ] [ \ another-forget-accessors-test class? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 3cacef25a1..546f7b15e8 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -7,10 +7,6 @@ classes classes.private slots.deprecated slots.private slots compiler.units math.private accessors assocs ; IN: classes.tuple -M: tuple delegate 2 slot ; - -M: tuple set-delegate 2 set-slot ; - M: tuple class 1 slot 2 slot { word } declare ; ERROR: no-tuple-class class ; @@ -19,7 +15,7 @@ ERROR: no-tuple-class class ; GENERIC: tuple-layout ( object -- layout ) -M: class tuple-layout "layout" word-prop ; +M: tuple-class tuple-layout "layout" word-prop ; M: tuple tuple-layout 1 slot ; @@ -40,7 +36,9 @@ PRIVATE> [ drop ] [ no-tuple-class ] if ; : tuple>array ( tuple -- array ) - prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ; + prepare-tuple>array + >r copy-tuple-slots r> + layout-class prefix ; : tuple-slots ( tuple -- array ) prepare-tuple>array drop copy-tuple-slots ; @@ -54,7 +52,8 @@ PRIVATE> unclip slots>tuple ; : slot-names ( class -- seq ) - "slot-names" word-prop ; + "slot-names" word-prop + [ dup array? [ second ] when ] map ; over superclass-size 2 + simple-slots ; : define-tuple-slots ( class -- ) - dup dup slot-names generate-tuple-slots + dup dup "slot-names" word-prop generate-tuple-slots [ "slots" set-word-prop ] [ define-accessors ] ! new [ define-slots ] ! old @@ -120,15 +119,6 @@ PRIVATE> : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: removed-slots ( class newslots -- seq ) - swap slot-names seq-diff ; - -: forget-removed-slots ( class slots -- ) - dupd removed-slots [ - [ reader-word forget-method ] - [ writer-word forget-method ] 2bi - ] with each ; - : all-slot-names ( class -- slots ) superclasses [ slot-names ] map concat \ class prefix ; @@ -161,25 +151,23 @@ PRIVATE> : update-tuples-after ( class -- ) outdated-tuples get [ all-slot-names ] cache drop ; -: subclasses ( class -- classes ) - class-usages keys [ tuple-class? ] subset ; - -: each-subclass ( class quot -- ) - >r subclasses r> each ; inline - -: define-tuple-shape ( class -- ) - [ define-tuple-slots ] +M: tuple-class update-class [ define-tuple-layout ] + [ define-tuple-slots ] [ define-tuple-predicate ] tri ; : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] [ nip "slot-names" set-word-prop ] - [ - 2drop - [ define-tuple-shape ] each-subclass - ] 3tri ; + [ 2drop update-classes ] + 3tri ; + +: subclasses ( class -- classes ) + class-usages keys [ tuple-class? ] subset ; + +: each-subclass ( class quot -- ) + >r subclasses r> each ; inline : redefine-tuple-class ( class superclass slots -- ) [ @@ -191,9 +179,8 @@ PRIVATE> tri ] each-subclass ] - [ nip forget-removed-slots ] [ define-new-tuple-class ] - 3tri ; + 3bi ; : tuple-class-unchanged? ( class superclass slots -- ? ) rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; @@ -214,6 +201,22 @@ M: tuple-class define-tuple-class [ define-tuple-class ] [ 2drop ] 3bi dup [ construct-boa throw ] curry define ; +M: tuple-class reset-class + [ + dup "slot-names" word-prop [ + [ reader-word method forget ] + [ writer-word method forget ] 2bi + ] with each + ] [ + { + "class" + "metaclass" + "superclass" + "layout" + "slots" + } reset-props + ] bi ; + M: tuple clone (clone) dup delegate clone over set-delegate ; @@ -227,26 +230,13 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -M: tuple-class reset-class - { "metaclass" "superclass" "slots" "layout" } reset-props ; - +! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; -M: object construct-empty ( class -- tuple ) - tuple-layout ; - -M: object construct-boa ( ... class -- tuple ) - tuple-layout ; - -! Deprecated M: object set-slots ( ... obj slots -- ) get-slots ; -M: object construct ( ... slots class -- tuple ) - construct-empty [ swap set-slots ] keep ; - -: delegates ( obj -- seq ) - [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; +: delegates ( obj -- seq ) [ delegate ] follow ; : is? ( obj quot -- ? ) >r delegates r> contains? ; inline diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor index 237f32c3e0..91726b6697 100755 --- a/core/classes/union/union-docs.factor +++ b/core/classes/union/union-docs.factor @@ -11,7 +11,9 @@ ARTICLE: "unions" "Union classes" { $subsection members } "The set of union classes is a class:" { $subsection union-class } -{ $subsection union-class? } ; +{ $subsection union-class? } +"Unions are used to define behavior shared between a fixed set of classes." +{ $see-also "mixins" "tuple-subclassing" } ; ABOUT: "unions" diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index e9b98770dc..09f8f88ced 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,33 +1,21 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -generic.standard namespaces arrays math quotations ; +namespaces arrays math quotations ; IN: classes.union PREDICATE: union-class < class "metaclass" word-prop union-class eq? ; ! Union classes for dispatch on multiple classes. -: small-union-predicate-quot ( members -- quot ) +: union-predicate-quot ( members -- quot ) dup empty? [ drop [ drop f ] ] [ - unclip first "predicate" word-prop swap - [ >r "predicate" word-prop [ dup ] prepend r> ] - assoc-map alist>quot - ] if ; - -: big-union-predicate-quot ( members -- quot ) - [ small-union-predicate-quot ] [ dup ] - class-hash-dispatch-quot ; - -: union-predicate-quot ( members -- quot ) - [ [ drop t ] ] { } map>assoc - dup length 4 <= [ - small-union-predicate-quot - ] [ - flatten-methods - big-union-predicate-quot + unclip "predicate" word-prop swap [ + "predicate" word-prop [ dup ] prepend + [ drop t ] + ] { } map>assoc alist>quot ] if ; : define-union-predicate ( class -- ) @@ -36,7 +24,9 @@ PREDICATE: union-class < class M: union-class update-class define-union-predicate ; : define-union-class ( class members -- ) - f swap union-class define-class ; + [ f swap union-class define-class ] + [ drop update-classes ] + 2bi ; M: union-class reset-class - { "metaclass" "members" } reset-props ; + { "class" "metaclass" "members" } reset-props ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 484c7ab730..139c6d8fdf 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -9,18 +9,24 @@ hashtables sorting ; [ call ] with each ; : cleave>quot ( seq -- quot ) - [ [ keep ] curry ] map concat [ drop ] append ; + [ [ keep ] curry ] map concat [ drop ] append [ ] like ; : 2cleave ( x seq -- ) - [ [ call ] 3keep drop ] each 2drop ; + [ 2keep ] each 2drop ; : 2cleave>quot ( seq -- quot ) - [ [ 2keep ] curry ] map concat [ 2drop ] append ; + [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ; + +: 3cleave ( x seq -- ) + [ 3keep ] each 3drop ; + +: 3cleave>quot ( seq -- quot ) + [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ; : spread>quot ( seq -- quot ) [ length [ >r ] concat ] [ [ [ r> ] prepend ] map concat ] bi - append ; + append [ ] like ; : spread ( objs... seq -- ) spread>quot call ; diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor index 72c1e063e0..246bf2dabe 100644 --- a/core/command-line/command-line.factor +++ b/core/command-line/command-line.factor @@ -47,7 +47,7 @@ SYMBOL: main-vocab-hook ] bind ; : ignore-cli-args? ( -- ? ) - macosx? "run" get "ui" = and ; + os macosx? "run" get "ui" = and ; : script-mode ( -- ) t "quiet" set-global diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 3520104e1f..341d56f1d5 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser assocs words.private sequences compiler.units ; IN: compiler +HELP: enable-compiler +{ $description "Enables the optimizing compiler." } ; + +HELP: disable-compiler +{ $description "Enables the optimizing compiler." } ; + ARTICLE: "compiler-usage" "Calling the optimizing compiler" -"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly." -$nl -"The main entry point to the optimizing compiler:" +"Normally, new word definitions are recompiled automatically. This can be changed:" +{ $subsection disable-compiler } +{ $subsection enable-compiler } +"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:" { $subsection optimized-recompile-hook } "Removing a word's optimized definition:" { $subsection decompile } -"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ; +"Higher-level words can be found in " { $link "compilation-units" } "." ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 111d84cde0..a0599f79a1 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -56,5 +56,11 @@ IN: compiler 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/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 7a8fe5d735..fadc57dc8d 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -174,11 +174,6 @@ sequences.private ; [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test -[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test -[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test -[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test -[ t ] [ f type f [ type ] compile-call eq? ] unit-test - [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test @@ -223,9 +218,6 @@ sequences.private ; [ t ] [ f [ f eq? ] compile-call ] unit-test -! regression -[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test - ! regression [ 3 ] [ 100001 f 3 100000 pick set-nth diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index bdbc985078..71da9436f1 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -4,7 +4,7 @@ USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences words kernel math effects definitions compiler.units ; -: ( n -- vreg ) T{ int-regs } ; +: ( n -- vreg ) int-regs ; [ [ ] [ init-templates ] unit-test @@ -15,18 +15,18 @@ words kernel math effects definitions compiler.units ; [ ] [ compute-free-vregs ] unit-test - [ f ] [ 0 T{ int-regs } free-vregs member? ] unit-test + [ f ] [ 0 int-regs free-vregs member? ] unit-test [ f ] [ [ copy-templates 1 phantom-push compute-free-vregs - 1 T{ int-regs } free-vregs member? + 1 int-regs free-vregs member? ] with-scope ] unit-test - [ t ] [ 1 T{ int-regs } free-vregs member? ] unit-test + [ t ] [ 1 int-regs free-vregs member? ] unit-test ] with-scope [ @@ -173,12 +173,12 @@ SYMBOL: template-chosen ] unit-test [ ] [ - 2 phantom-d get phantom-input + 2 phantom-datastack get phantom-input [ { { f "a" } { f "b" } } lazy-load ] { } make drop ] unit-test [ t ] [ - phantom-d get [ cached? ] all? + phantom-datastack get [ cached? ] all? ] unit-test ! >r diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 081a8fd47c..845189ce2c 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -26,10 +26,6 @@ IN: compiler.tests [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ] unit-test -[ { 1 2 3 } { 1 4 3 } 8 8 ] -[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ] -unit-test - ! Test literals in either side of a shuffle [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test @@ -176,14 +172,14 @@ TUPLE: my-tuple ; [ 1 t ] [ B{ 1 2 3 4 } [ { c-ptr } declare - [ 0 alien-unsigned-1 ] keep type + [ 0 alien-unsigned-1 ] keep hi-tag ] compile-call byte-array type-number = ] unit-test [ t ] [ B{ 1 2 3 4 } [ { c-ptr } declare - 0 alien-cell type + 0 alien-cell hi-tag ] compile-call alien type-number = ] unit-test @@ -206,3 +202,47 @@ TUPLE: my-tuple ; ] [ 2drop no-case ] if ] compile-call ] unit-test + +: float-spill-bug + { + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + } cleave ; + +[ t ] [ \ float-spill-bug compiled? ] unit-test diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index 5843575eeb..97cde6261c 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -22,11 +22,3 @@ TUPLE: color red green blue ; [ T{ color f f f f } ] [ [ color construct-empty ] compile-call ] unit-test - -[ T{ color "a" f "b" f } ] [ - "a" "b" - [ { set-delegate set-color-green } color construct ] - compile-call -] unit-test - -[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index ca7af930f2..b3adb1b165 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private continuations.private parser vectors arrays namespaces -assocs words quotations ; +assocs words quotations io ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -17,6 +17,25 @@ ARTICLE: "errors-post-mortem" "Post-mortem error inspection" { $subsection error-continuation } "Developer tools for inspecting these values are found in " { $link "debugger" } "." ; +ARTICLE: "errors-anti-examples" "Common error handling pitfalls" +"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind." +{ $heading "Anti-pattern #1: Ignoring errors" } +"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user." +{ $heading "Anti-pattern #2: Catching errors too early" } +"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible." +$nl +"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically." +{ $heading "Anti-pattern #3: Dropping and rethrowing" } +"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught." +{ $heading "Anti-pattern #4: Logging and rethrowing" } +"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." +{ $heading "Anti-pattern #5: Leaking external resources" } +"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:" +{ $code + " ... do stuff ... dispose" +} +"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ; + ARTICLE: "errors" "Error handling" "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." $nl @@ -27,10 +46,13 @@ $nl { $subsection cleanup } { $subsection recover } { $subsection ignore-errors } +"Syntax sugar for defining errors:" +{ $subsection POSTPONE: ERROR: } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "debugger" } { $subsection "errors-post-mortem" } +{ $subsection "errors-anti-examples" } "When Factor encouters a critical error, it calls the following word:" { $subsection die } ; @@ -61,8 +83,7 @@ $nl "Another two words resume continuations:" { $subsection continue } { $subsection continue-with } -"Continuations serve as the building block for a number of higher-level abstractions." -{ $subsection "errors" } +"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; ABOUT: "continuations" diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index a2c296e8ce..cf67280cca 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -141,14 +141,9 @@ GENERIC: dispose ( object -- ) : with-disposal ( object quot -- ) over [ dispose ] curry [ ] cleanup ; inline -TUPLE: condition restarts continuation ; +TUPLE: condition error restarts continuation ; -: ( error restarts cc -- condition ) - { - set-delegate - set-condition-restarts - set-condition-continuation - } condition construct ; +C: condition ( error restarts cc -- condition ) : throw-restarts ( error restarts -- restart ) [ throw ] callcc1 2nip ; @@ -161,15 +156,14 @@ TUPLE: restart name obj continuation ; C: restart : restart ( restart -- ) - dup restart-obj swap restart-continuation continue-with ; + [ obj>> ] [ continuation>> ] bi continue-with ; M: object compute-restarts drop { } ; -M: tuple compute-restarts delegate compute-restarts ; - M: condition compute-restarts - [ delegate compute-restarts ] keep - [ condition-restarts ] keep - condition-continuation - [ ] curry { } assoc>map - append ; + [ error>> compute-restarts ] + [ + [ restarts>> ] + [ condition-continuation [ ] curry ] bi + { } assoc>map + ] bi append ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 8d1e1f281f..7ea8849d30 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -5,10 +5,8 @@ namespaces sequences layouts system hashtables classes alien byte-arrays bit-arrays float-arrays combinators words ; IN: cpu.architecture -SYMBOL: compiler-backend - ! A pseudo-register class for parameters spilled on the stack -TUPLE: stack-params ; +SINGLETON: stack-params ! Return values of this class go here GENERIC: return-reg ( register-class -- reg ) @@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs ) ! Load a literal (immediate or indirect) GENERIC# load-literal 1 ( obj vreg -- ) -HOOK: load-indirect compiler-backend ( obj reg -- ) +HOOK: load-indirect cpu ( obj reg -- ) -HOOK: stack-frame compiler-backend ( frame-size -- n ) +HOOK: stack-frame cpu ( frame-size -- n ) : stack-frame* ( -- n ) \ stack-frame get stack-frame ; ! Set up caller stack frame -HOOK: %prologue compiler-backend ( n -- ) +HOOK: %prologue cpu ( n -- ) : %prologue-later \ %prologue-later , ; ! Tear down stack frame -HOOK: %epilogue compiler-backend ( n -- ) +HOOK: %epilogue cpu ( n -- ) : %epilogue-later \ %epilogue-later , ; ! Store word XT in stack frame -HOOK: %save-word-xt compiler-backend ( -- ) +HOOK: %save-word-xt cpu ( -- ) ! Store dispatch branch XT in stack frame -HOOK: %save-dispatch-xt compiler-backend ( -- ) +HOOK: %save-dispatch-xt cpu ( -- ) M: object %save-dispatch-xt %save-word-xt ; ! Call another word -HOOK: %call compiler-backend ( word -- ) +HOOK: %call cpu ( word -- ) ! Local jump for branches -HOOK: %jump-label compiler-backend ( label -- ) +HOOK: %jump-label cpu ( label -- ) ! Test if vreg is 'f' or not -HOOK: %jump-t compiler-backend ( label -- ) +HOOK: %jump-t cpu ( label -- ) -HOOK: %dispatch compiler-backend ( -- ) +HOOK: %dispatch cpu ( -- ) -HOOK: %dispatch-label compiler-backend ( word -- ) +HOOK: %dispatch-label cpu ( word -- ) ! Return to caller -HOOK: %return compiler-backend ( -- ) +HOOK: %return cpu ( -- ) ! Change datastack height -HOOK: %inc-d compiler-backend ( n -- ) +HOOK: %inc-d cpu ( n -- ) ! Change callstack height -HOOK: %inc-r compiler-backend ( n -- ) +HOOK: %inc-r cpu ( n -- ) ! Load stack into vreg -HOOK: %peek compiler-backend ( vreg loc -- ) +HOOK: %peek cpu ( vreg loc -- ) ! Store vreg to stack -HOOK: %replace compiler-backend ( vreg loc -- ) +HOOK: %replace cpu ( vreg loc -- ) ! Box and unbox floats -HOOK: %unbox-float compiler-backend ( dst src -- ) -HOOK: %box-float compiler-backend ( dst src -- ) +HOOK: %unbox-float cpu ( dst src -- ) +HOOK: %box-float cpu ( dst src -- ) ! FFI stuff ! Is this integer small enough to appear in value template ! slots? -HOOK: small-enough? compiler-backend ( n -- ? ) +HOOK: small-enough? cpu ( n -- ? ) ! Is this structure small enough to be returned in registers? -HOOK: struct-small-enough? compiler-backend ( size -- ? ) +HOOK: struct-small-enough? cpu ( size -- ? ) ! Do we pass explode value structs? -HOOK: value-structs? compiler-backend ( -- ? ) +HOOK: value-structs? cpu ( -- ? ) ! If t, fp parameters are shadowed by dummy int parameters -HOOK: fp-shadows-int? compiler-backend ( -- ? ) +HOOK: fp-shadows-int? cpu ( -- ? ) -HOOK: %prepare-unbox compiler-backend ( -- ) +HOOK: %prepare-unbox cpu ( -- ) -HOOK: %unbox compiler-backend ( n reg-class func -- ) +HOOK: %unbox cpu ( n reg-class func -- ) -HOOK: %unbox-long-long compiler-backend ( n func -- ) +HOOK: %unbox-long-long cpu ( n func -- ) -HOOK: %unbox-small-struct compiler-backend ( size -- ) +HOOK: %unbox-small-struct cpu ( size -- ) -HOOK: %unbox-large-struct compiler-backend ( n size -- ) +HOOK: %unbox-large-struct cpu ( n size -- ) -HOOK: %box compiler-backend ( n reg-class func -- ) +HOOK: %box cpu ( n reg-class func -- ) -HOOK: %box-long-long compiler-backend ( n func -- ) +HOOK: %box-long-long cpu ( n func -- ) -HOOK: %prepare-box-struct compiler-backend ( size -- ) +HOOK: %prepare-box-struct cpu ( size -- ) -HOOK: %box-small-struct compiler-backend ( size -- ) +HOOK: %box-small-struct cpu ( size -- ) -HOOK: %box-large-struct compiler-backend ( n size -- ) +HOOK: %box-large-struct cpu ( n size -- ) GENERIC: %save-param-reg ( stack reg reg-class -- ) GENERIC: %load-param-reg ( stack reg reg-class -- ) -HOOK: %prepare-alien-invoke compiler-backend ( -- ) +HOOK: %prepare-alien-invoke cpu ( -- ) -HOOK: %prepare-var-args compiler-backend ( -- ) +HOOK: %prepare-var-args cpu ( -- ) M: object %prepare-var-args ; -HOOK: %alien-invoke compiler-backend ( function library -- ) +HOOK: %alien-invoke cpu ( function library -- ) -HOOK: %cleanup compiler-backend ( alien-node -- ) +HOOK: %cleanup cpu ( alien-node -- ) -HOOK: %alien-callback compiler-backend ( quot -- ) +HOOK: %alien-callback cpu ( quot -- ) -HOOK: %callback-value compiler-backend ( ctype -- ) +HOOK: %callback-value cpu ( ctype -- ) ! Return to caller with stdcall unwinding (only for x86) -HOOK: %unwind compiler-backend ( n -- ) +HOOK: %unwind cpu ( n -- ) -HOOK: %prepare-alien-indirect compiler-backend ( -- ) +HOOK: %prepare-alien-indirect cpu ( -- ) -HOOK: %alien-indirect compiler-backend ( -- ) +HOOK: %alien-indirect cpu ( -- ) M: stack-params param-reg drop ; @@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ; ] if-small-struct ; ! Alien accessors -HOOK: %unbox-byte-array compiler-backend ( dst src -- ) +HOOK: %unbox-byte-array cpu ( dst src -- ) -HOOK: %unbox-alien compiler-backend ( dst src -- ) +HOOK: %unbox-alien cpu ( dst src -- ) -HOOK: %unbox-f compiler-backend ( dst src -- ) +HOOK: %unbox-f cpu ( dst src -- ) -HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- ) +HOOK: %unbox-any-c-ptr cpu ( dst src -- ) -HOOK: %box-alien compiler-backend ( dst src -- ) +HOOK: %box-alien cpu ( dst src -- ) : operand ( var -- op ) get v>operand ; inline diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index 6c37fce4f1..34ea82dc4e 100755 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -32,7 +32,7 @@ IN: cpu.ppc.allot 12 11 float tag-number ORI f fresh-object ; -M: ppc-backend %box-float ( dst src -- ) +M: ppc %box-float ( dst src -- ) [ v>operand ] bi@ %allot-float 12 MR ; : %allot-bignum ( #digits -- ) @@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- ) "end" resolve-label ] with-scope ; -M: ppc-backend %box-alien ( dst src -- ) +M: ppc %box-alien ( dst src -- ) { "end" "f" } [ define-label ] each 0 over v>operand 0 CMPI "f" get BEQ diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 903ac32df9..bd5273efcb 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -7,8 +7,6 @@ layouts classes words.private alien combinators compiler.constants ; IN: cpu.ppc.architecture -TUPLE: ppc-backend ; - ! PowerPC register assignments ! r3-r10, r16-r31: integer vregs ! f0-f13: float vregs @@ -21,14 +19,14 @@ TUPLE: ppc-backend ; : reserved-area-size os { - { "linux" [ 2 ] } - { "macosx" [ 6 ] } + { linux [ 2 ] } + { macosx [ 6 ] } } case cells ; foldable : lr-save os { - { "linux" [ 1 ] } - { "macosx" [ 2 ] } + { linux [ 1 ] } + { macosx [ 2 ] } } case cells ; foldable : param@ ( n -- x ) reserved-area-size + ; inline @@ -44,7 +42,7 @@ TUPLE: ppc-backend ; : xt-save ( n -- i ) 2 cells - ; -M: ppc-backend stack-frame ( n -- i ) +M: ppc stack-frame ( n -- i ) local@ factor-area-size + 4 cells align ; M: temp-reg v>operand drop 11 ; @@ -60,8 +58,8 @@ M: int-regs vregs M: float-regs return-reg drop 1 ; M: float-regs param-regs drop os H{ - { "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } } - { "linux" { 1 2 3 4 5 6 7 8 } } + { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } } + { linux { 1 2 3 4 5 6 7 8 } } } at ; M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; @@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ; M: immediate load-literal [ v>operand ] bi@ LOAD ; -M: ppc-backend load-indirect ( obj reg -- ) +M: ppc load-indirect ( obj reg -- ) [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep dup 0 LWZ ; -M: ppc-backend %save-word-xt ( -- ) +M: ppc %save-word-xt ( -- ) 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ; -M: ppc-backend %prologue ( n -- ) +M: ppc %prologue ( n -- ) 0 MFLR 1 1 pick neg ADDI 11 1 pick xt-save STW @@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- ) 11 1 pick next-save STW 0 1 rot lr-save + STW ; -M: ppc-backend %epilogue ( n -- ) +M: ppc %epilogue ( n -- ) #! At the end of each word that calls a subroutine, we store #! the previous link register value in r0 by popping it off #! the stack, set the link register to the contents of r0, @@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- ) : %load-dlsym ( symbol dll register -- ) 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; -M: ppc-backend %call ( label -- ) BL ; +M: ppc %call ( label -- ) BL ; -M: ppc-backend %jump-label ( label -- ) B ; +M: ppc %jump-label ( label -- ) B ; -M: ppc-backend %jump-t ( label -- ) +M: ppc %jump-t ( label -- ) 0 "flag" operand f v>operand CMPI BNE ; -M: ppc-backend %dispatch ( -- ) +M: ppc %dispatch ( -- ) [ %epilogue-later 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here @@ -124,35 +122,43 @@ M: ppc-backend %dispatch ( -- ) { +scratch+ { { f "offset" } } } } with-template ; -M: ppc-backend %dispatch-label ( word -- ) +M: ppc %dispatch-label ( word -- ) 0 , rc-absolute-cell rel-word ; -M: ppc-backend %return ( -- ) %epilogue-later BLR ; +M: ppc %return ( -- ) %epilogue-later BLR ; -M: ppc-backend %unwind drop %return ; +M: ppc %unwind drop %return ; -M: ppc-backend %peek ( vreg loc -- ) +M: ppc %peek ( vreg loc -- ) >r v>operand r> loc>operand LWZ ; -M: ppc-backend %replace +M: ppc %replace >r v>operand r> loc>operand STW ; -M: ppc-backend %unbox-float ( dst src -- ) +M: ppc %unbox-float ( dst src -- ) [ v>operand ] bi@ float-offset LFD ; -M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ; +M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ; -M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ; +M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ; M: int-regs %save-param-reg drop 1 rot local@ STW ; M: int-regs %load-param-reg drop 1 rot local@ LWZ ; -: STF float-regs-size 4 = [ STFS ] [ STFD ] if ; +GENERIC: STF ( src dst reg-class -- ) + +M: single-float-regs STF drop STFS ; + +M: double-float-regs STF drop STFD ; M: float-regs %save-param-reg >r 1 rot local@ r> STF ; -: LF float-regs-size 4 = [ LFS ] [ LFD ] if ; +GENERIC: LF ( src dst reg-class -- ) + +M: single-float-regs LF drop LFS ; + +M: double-float-regs LF drop LFD ; M: float-regs %load-param-reg >r 1 rot local@ r> LF ; @@ -166,19 +172,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- ) 0 1 rot param@ stack-frame* + LWZ 0 1 rot local@ STW ; -M: ppc-backend %prepare-unbox ( -- ) +M: ppc %prepare-unbox ( -- ) ! First parameter is top of stack 3 ds-reg 0 LWZ ds-reg dup cell SUBI ; -M: ppc-backend %unbox ( n reg-class func -- ) +M: ppc %unbox ( n reg-class func -- ) ! Value must be in r3 ! Call the unboxer f %alien-invoke ! Store the return value on the C stack over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; -M: ppc-backend %unbox-long-long ( n func -- ) +M: ppc %unbox-long-long ( n func -- ) ! Value must be in r3:r4 ! Call the unboxer f %alien-invoke @@ -188,7 +194,7 @@ M: ppc-backend %unbox-long-long ( n func -- ) 4 1 rot cell + local@ STW ] when* ; -M: ppc-backend %unbox-large-struct ( n size -- ) +M: ppc %unbox-large-struct ( n size -- ) ! Value must be in r3 ! Compute destination address 4 1 roll local@ ADDI @@ -197,7 +203,7 @@ M: ppc-backend %unbox-large-struct ( n size -- ) ! Call the function "to_value_struct" f %alien-invoke ; -M: ppc-backend %box ( n reg-class func -- ) +M: ppc %box ( n reg-class func -- ) ! If the source is a stack location, load it into freg #0. ! If the source is f, then we assume the value is already in ! freg #0. @@ -205,7 +211,7 @@ M: ppc-backend %box ( n reg-class func -- ) over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if r> f %alien-invoke ; -M: ppc-backend %box-long-long ( n func -- ) +M: ppc %box-long-long ( n func -- ) >r [ 3 1 pick local@ LWZ 4 1 rot cell + local@ LWZ @@ -215,12 +221,12 @@ M: ppc-backend %box-long-long ( n func -- ) : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ; -M: ppc-backend %prepare-box-struct ( size -- ) +M: ppc %prepare-box-struct ( size -- ) #! Compute target address for value struct return 3 1 rot f struct-return@ ADDI 3 1 0 local@ STW ; -M: ppc-backend %box-large-struct ( n size -- ) +M: ppc %box-large-struct ( n size -- ) #! If n = f, then we're boxing a returned struct [ swap struct-return@ ] keep ! Compute destination address @@ -230,7 +236,7 @@ M: ppc-backend %box-large-struct ( n size -- ) ! Call the function "box_value_struct" f %alien-invoke ; -M: ppc-backend %prepare-alien-invoke +M: ppc %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. @@ -240,20 +246,20 @@ M: ppc-backend %prepare-alien-invoke ds-reg 11 8 STW rs-reg 11 12 STW ; -M: ppc-backend %alien-invoke ( symbol dll -- ) +M: ppc %alien-invoke ( symbol dll -- ) 11 %load-dlsym (%call) ; -M: ppc-backend %alien-callback ( quot -- ) +M: ppc %alien-callback ( quot -- ) 3 load-indirect "c_to_factor" f %alien-invoke ; -M: ppc-backend %prepare-alien-indirect ( -- ) +M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke 3 1 cell temp@ STW ; -M: ppc-backend %alien-indirect ( -- ) +M: ppc %alien-indirect ( -- ) 11 1 cell temp@ LWZ (%call) ; -M: ppc-backend %callback-value ( ctype -- ) +M: ppc %callback-value ( ctype -- ) ! Save top of data stack 3 ds-reg 0 LWZ 3 1 0 local@ STW @@ -264,7 +270,7 @@ M: ppc-backend %callback-value ( ctype -- ) ! Unbox former top of data stack to return registers unbox-return ; -M: ppc-backend %cleanup ( alien-node -- ) drop ; +M: ppc %cleanup ( alien-node -- ) drop ; : %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ; @@ -272,34 +278,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ; : %untag-fixnum ( dest src -- ) tag-bits get SRAWI ; -M: ppc-backend value-structs? +M: ppc value-structs? #! On Linux/PPC, value structs are passed in the same way #! as reference structs, we just have to make a copy first. - linux? not ; + os linux? not ; -M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ; +M: ppc fp-shadows-int? ( -- ? ) os macosx? ; -M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ; +M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; -M: ppc-backend struct-small-enough? ( size -- ? ) drop f ; +M: ppc struct-small-enough? ( size -- ? ) drop f ; -M: ppc-backend %box-small-struct +M: ppc %box-small-struct drop "No small structs" throw ; -M: ppc-backend %unbox-small-struct +M: ppc %unbox-small-struct drop "No small structs" throw ; ! Alien intrinsics -M: ppc-backend %unbox-byte-array ( dst src -- ) +M: ppc %unbox-byte-array ( dst src -- ) [ v>operand ] bi@ byte-array-offset ADDI ; -M: ppc-backend %unbox-alien ( dst src -- ) +M: ppc %unbox-alien ( dst src -- ) [ v>operand ] bi@ alien-offset LWZ ; -M: ppc-backend %unbox-f ( dst src -- ) +M: ppc %unbox-f ( dst src -- ) drop 0 swap v>operand LI ; -M: ppc-backend %unbox-any-c-ptr ( dst src -- ) +M: ppc %unbox-any-c-ptr ( dst src -- ) { "is-byte-array" "end" "start" } [ define-label ] each ! Address is computed in R12 0 12 LI diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 07698eaa92..d092473960 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics { +output+ { "out" } } } define-intrinsic -\ type [ - "end" define-label - ! Get the tag - "y" operand "obj" operand tag-mask get ANDI - ! Tag the tag - "y" operand "x" operand %tag-fixnum - ! Compare with object tag number (3). - 0 "y" operand object tag-number CMPI - ! Jump if the object doesn't store type info in its header - "end" get BNE - ! It does store type info in its header - "x" operand "obj" operand header-offset LWZ - "end" resolve-label -] H{ - { +input+ { { f "obj" } } } - { +scratch+ { { f "x" } { f "y" } } } - { +output+ { "x" } } -} define-intrinsic - -\ class-hash [ - "end" define-label - "tuple" define-label - "object" define-label - ! Get the tag - "y" operand "obj" operand tag-mask get ANDI - ! Compare with tuple tag number (2). - 0 "y" operand tuple tag-number CMPI - "tuple" get BEQ - ! Compare with object tag number (3). - 0 "y" operand object tag-number CMPI - "object" get BEQ - ! Tag the tag - "y" operand "x" operand %tag-fixnum - "end" get B - "object" get resolve-label - ! Load header type - "x" operand "obj" operand header-offset LWZ - "end" get B - "tuple" get resolve-label - ! Load class hash - "x" operand "obj" operand tuple-class-offset LWZ - "x" operand dup class-hash-offset LWZ - "end" resolve-label -] H{ - { +input+ { { f "obj" } } } - { +scratch+ { { f "x" } { f "y" } } } - { +output+ { "x" } } -} define-intrinsic - : userenv ( reg -- ) #! Load the userenv pointer in a register. "userenv" f rot %load-dlsym ; diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor index 75de49acda..eede86085b 100755 --- a/core/cpu/ppc/ppc.factor +++ b/core/cpu/ppc/ppc.factor @@ -2,18 +2,13 @@ USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture namespaces alien.c-types kernel system combinators ; { - { [ macosx? ] [ + { [ os macosx? ] [ 4 "longlong" c-type set-c-type-align 4 "ulonglong" c-type set-c-type-align + 4 "double" c-type set-c-type-align ] } - { [ linux? ] [ + { [ os linux? ] [ t "longlong" c-type set-c-type-stack-align? t "ulonglong" c-type set-c-type-stack-align? ] } } cond - -T{ ppc-backend } compiler-backend set-global - -macosx? [ - 4 "double" c-type set-c-type-align -] when diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index f4af421cdd..699670aecd 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -8,23 +8,20 @@ alien.compiler combinators command-line compiler compiler.units io vocabs.loader accessors ; IN: cpu.x86.32 -PREDICATE: x86-32-backend < x86-backend - x86-backend-cell 4 = ; - ! We implement the FFI for Linux, OS X and Windows all at once. ! OS X requires that the stack be 16-byte aligned, and we do ! this on all platforms, sacrificing some stack space for ! code simplicity. -M: x86-32-backend ds-reg ESI ; -M: x86-32-backend rs-reg EDI ; -M: x86-32-backend stack-reg ESP ; -M: x86-32-backend xt-reg ECX ; -M: x86-32-backend stack-save-reg EDX ; +M: x86.32 ds-reg ESI ; +M: x86.32 rs-reg EDI ; +M: x86.32 stack-reg ESP ; +M: x86.32 xt-reg ECX ; +M: x86.32 stack-save-reg EDX ; M: temp-reg v>operand drop EBX ; -M: x86-32-backend %alien-invoke ( symbol dll -- ) +M: x86.32 %alien-invoke ( symbol dll -- ) (CALL) rel-dlsym ; ! On x86, parameters are never passed in registers. @@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ; ! On x86, we can always use an address as an operand ! directly. -M: x86-32-backend address-operand ; +M: x86.32 address-operand ; -M: x86-32-backend fixnum>slot@ 1 SHR ; +M: x86.32 fixnum>slot@ 1 SHR ; -M: x86-32-backend prepare-division CDQ ; +M: x86.32 prepare-division CDQ ; -M: x86-32-backend load-indirect +M: x86.32 load-indirect 0 [] MOV rc-absolute-cell rel-literal ; M: object %load-param-reg 3drop ; M: object %save-param-reg 3drop ; -M: x86-32-backend %prepare-unbox ( -- ) +M: x86.32 %prepare-unbox ( -- ) #! Move top of data stack to EAX. EAX ESI [] MOV ESI 4 SUB ; @@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- ) f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %unbox ( n reg-class func -- ) +M: x86.32 %unbox ( n reg-class func -- ) #! The value being unboxed must already be in EAX. #! If n is f, we're unboxing a return value about to be #! returned by the callback. Otherwise, we're unboxing @@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- ) ! Store the return value on the C stack over [ store-return-reg ] [ 2drop ] if ; -M: x86-32-backend %unbox-long-long ( n func -- ) +M: x86.32 %unbox-long-long ( n func -- ) (%unbox) ! Store the return value on the C stack [ @@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- ) cell + stack@ EDX MOV ] when* ; -M: x86-32-backend %unbox-struct-2 +M: x86.32 %unbox-struct-2 #! Alien must be in EAX. 4 [ EAX PUSH @@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2 EAX EAX [] MOV ] with-aligned-stack ; -M: x86-32-backend %unbox-large-struct ( n size -- ) +M: x86.32 %unbox-large-struct ( n size -- ) #! Alien must be in EAX. ! Compute destination address ECX ESP roll [+] LEA @@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- ) over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if push-return-reg ; -M: x86-32-backend %box ( n reg-class func -- ) +M: x86.32 %box ( n reg-class func -- ) over reg-size [ >r (%box) r> f %alien-invoke ] with-aligned-stack ; @@ -158,19 +155,19 @@ M: x86-32-backend %box ( n reg-class func -- ) #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are #! boxing a parameter being passed to a callback from C. [ - T{ int-regs } box@ + int-regs box@ EDX over stack@ MOV EAX swap cell - stack@ MOV ] when* EDX PUSH EAX PUSH ; -M: x86-32-backend %box-long-long ( n func -- ) +M: x86.32 %box-long-long ( n func -- ) 8 [ >r (%box-long-long) r> f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %box-large-struct ( n size -- ) +M: x86.32 %box-large-struct ( n size -- ) ! Compute destination address [ swap struct-return@ ] keep ECX ESP roll [+] LEA @@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- ) "box_value_struct" f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %prepare-box-struct ( size -- ) +M: x86.32 %prepare-box-struct ( size -- ) ! Compute target address for value struct return EAX ESP rot f struct-return@ [+] LEA ! Store it as the first parameter ESP [] EAX MOV ; -M: x86-32-backend %unbox-struct-1 +M: x86.32 %unbox-struct-1 #! Alien must be in EAX. 4 [ EAX PUSH @@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1 EAX EAX [] MOV ] with-aligned-stack ; -M: x86-32-backend %box-small-struct ( size -- ) +M: x86.32 %box-small-struct ( size -- ) #! Box a <= 8-byte struct returned in EAX:DX. OS X only. 12 [ PUSH @@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- ) "box_small_struct" f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %prepare-alien-indirect ( -- ) +M: x86.32 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke cell temp@ EAX MOV ; -M: x86-32-backend %alien-indirect ( -- ) +M: x86.32 %alien-indirect ( -- ) cell temp@ CALL ; -M: x86-32-backend %alien-callback ( quot -- ) +M: x86.32 %alien-callback ( quot -- ) 4 [ EAX load-indirect EAX PUSH "c_to_factor" f %alien-invoke ] with-aligned-stack ; -M: x86-32-backend %callback-value ( ctype -- ) +M: x86.32 %callback-value ( ctype -- ) ! Align C stack ESP 12 SUB ! Save top of data stack @@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- ) ! Unbox EAX unbox-return ; -M: x86-32-backend %cleanup ( alien-node -- ) +M: x86.32 %cleanup ( alien-node -- ) #! a) If we just called an stdcall function in Windows, it #! cleaned up the stack frame for us. But we don't want that #! so we 'undo' the cleanup since we do that in %epilogue. @@ -254,19 +251,14 @@ M: x86-32-backend %cleanup ( alien-node -- ) } } cond ; -M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ; +M: x86.32 %unwind ( n -- ) %epilogue-later RET ; -windows? [ +os windows? [ cell "longlong" c-type set-c-type-align cell "ulonglong" c-type set-c-type-align -] unless - -windows? [ 4 "double" c-type set-c-type-align ] unless -T{ x86-backend f 4 } compiler-backend set-global - : sse2? "Intrinsic" throw ; \ sse2? [ diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index c2af60e983..811387675a 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots splitting assocs ; IN: cpu.x86.64 -PREDICATE: amd64-backend < x86-backend - x86-backend-cell 8 = ; - -M: amd64-backend ds-reg R14 ; -M: amd64-backend rs-reg R15 ; -M: amd64-backend stack-reg RSP ; -M: amd64-backend xt-reg RCX ; -M: amd64-backend stack-save-reg RSI ; +M: x86.64 ds-reg R14 ; +M: x86.64 rs-reg R15 ; +M: x86.64 stack-reg RSP ; +M: x86.64 xt-reg RCX ; +M: x86.64 stack-save-reg RSI ; M: temp-reg v>operand drop RBX ; @@ -34,18 +31,18 @@ M: float-regs vregs M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; -M: amd64-backend address-operand ( address -- operand ) +M: x86.64 address-operand ( address -- operand ) #! On AMD64, we have to load 64-bit addresses into a #! scratch register first. The usage of R11 here is a hack. #! This word can only be called right before a subroutine #! call, where all vregs have been flushed anyway. temp-reg v>operand [ swap MOV ] keep ; -M: amd64-backend fixnum>slot@ drop ; +M: x86.64 fixnum>slot@ drop ; -M: amd64-backend prepare-division CQO ; +M: x86.64 prepare-division CQO ; -M: amd64-backend load-indirect ( literal reg -- ) +M: x86.64 load-indirect ( literal reg -- ) 0 [] MOV rc-relative rel-literal ; M: stack-params %load-param-reg @@ -56,27 +53,27 @@ M: stack-params %load-param-reg M: stack-params %save-param-reg >r stack-frame* + cell + swap r> %load-param-reg ; -M: amd64-backend %prepare-unbox ( -- ) +M: x86.64 %prepare-unbox ( -- ) ! First parameter is top of stack RDI R14 [] MOV R14 cell SUB ; -M: amd64-backend %unbox ( n reg-class func -- ) +M: x86.64 %unbox ( n reg-class func -- ) ! Call the unboxer f %alien-invoke ! Store the return value on the C stack over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; -M: amd64-backend %unbox-long-long ( n func -- ) - T{ int-regs } swap %unbox ; +M: x86.64 %unbox-long-long ( n func -- ) + int-regs swap %unbox ; -M: amd64-backend %unbox-struct-1 ( -- ) +M: x86.64 %unbox-struct-1 ( -- ) #! Alien must be in RDI. "alien_offset" f %alien-invoke ! Load first cell RAX RAX [] MOV ; -M: amd64-backend %unbox-struct-2 ( -- ) +M: x86.64 %unbox-struct-2 ( -- ) #! Alien must be in RDI. "alien_offset" f %alien-invoke ! Load second cell @@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- ) ! Load first cell RAX RAX [] MOV ; -M: amd64-backend %unbox-large-struct ( n size -- ) +M: x86.64 %unbox-large-struct ( n size -- ) ! Source is in RDI ! Load destination address RSI RSP roll [+] LEA @@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- ) 0 over param-reg swap return-reg 2dup eq? [ 2drop ] [ MOV ] if ; -M: amd64-backend %box ( n reg-class func -- ) +M: x86.64 %box ( n reg-class func -- ) rot [ rot [ 0 swap param-reg ] keep %load-param-reg ] [ @@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- ) ] if* f %alien-invoke ; -M: amd64-backend %box-long-long ( n func -- ) - T{ int-regs } swap %box ; +M: x86.64 %box-long-long ( n func -- ) + int-regs swap %box ; -M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ; +M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ; -M: amd64-backend %box-small-struct ( size -- ) +M: x86.64 %box-small-struct ( size -- ) #! Box a <= 16-byte struct returned in RAX:RDX. RDI RAX MOV RSI RDX MOV RDX swap MOV "box_small_struct" f %alien-invoke ; -M: amd64-backend %box-large-struct ( n size -- ) +M: x86.64 %box-large-struct ( n size -- ) ! Struct size is parameter 2 RSI over MOV ! Compute destination address @@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- ) ! Copy the struct from the C stack "box_value_struct" f %alien-invoke ; -M: amd64-backend %prepare-box-struct ( size -- ) +M: x86.64 %prepare-box-struct ( size -- ) ! Compute target address for value struct return RAX RSP rot f struct-return@ [+] LEA RSP 0 [+] RAX MOV ; -M: amd64-backend %prepare-var-args RAX RAX XOR ; +M: x86.64 %prepare-var-args RAX RAX XOR ; -M: amd64-backend %alien-invoke ( symbol dll -- ) +M: x86.64 %alien-invoke ( symbol dll -- ) 0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ; -M: amd64-backend %prepare-alien-indirect ( -- ) +M: x86.64 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke cell temp@ RAX MOV ; -M: amd64-backend %alien-indirect ( -- ) +M: x86.64 %alien-indirect ( -- ) cell temp@ CALL ; -M: amd64-backend %alien-callback ( quot -- ) +M: x86.64 %alien-callback ( quot -- ) RDI load-indirect "c_to_factor" f %alien-invoke ; -M: amd64-backend %callback-value ( ctype -- ) +M: x86.64 %callback-value ( ctype -- ) ! Save top of data stack %prepare-unbox ! Put former top of data stack in RDI @@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- ) ! Unbox former top of data stack to return registers unbox-return ; -M: amd64-backend %cleanup ( alien-node -- ) drop ; +M: x86.64 %cleanup ( alien-node -- ) drop ; -M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ; +M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ; USE: cpu.x86.intrinsics @@ -171,11 +168,9 @@ USE: cpu.x86.intrinsics \ alien-signed-4 small-reg-32 define-signed-getter \ set-alien-signed-4 small-reg-32 define-setter -T{ x86-backend f 8 } compiler-backend set-global - ! The ABI for passing structs by value is pretty messed up << "void*" c-type clone "__stack_value" define-primitive-type -T{ stack-params } "__stack_value" c-type set-c-type-reg-class >> +stack-params "__stack_value" c-type set-c-type-reg-class >> : struct-types&offset ( struct-type -- pairs ) struct-type-fields [ @@ -197,7 +192,7 @@ M: struct-type flatten-value-type ( type -- seq ) ] [ struct-types&offset split-struct [ [ c-type c-type-reg-class ] map - T{ int-regs } swap member? + int-regs swap member? "void*" "double" ? c-type , ] each ] if ; diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index 5519a9a8d5..f236cdcfa6 100755 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -46,7 +46,7 @@ IN: cpu.x86.allot allot-reg swap tag-number OR allot-reg MOV ; -M: x86-backend %box-float ( dst src -- ) +M: x86 %box-float ( dst src -- ) #! Only called by pentium4 backend, uses SSE2 instruction #! dest is a loc or a vreg float 16 [ @@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- ) "end" resolve-label ] with-scope ; -M: x86-backend %box-alien ( dst src -- ) +M: x86 %box-alien ( dst src -- ) [ { "end" "f" } [ define-label ] each dup v>operand 0 CMP diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 31fa4c8e4b..25bb3c6e07 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.compiler arrays cpu.x86.assembler cpu.architecture kernel kernel.private math @@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers generator.fixup system layouts combinators compiler.constants ; IN: cpu.x86.architecture -TUPLE: x86-backend cell ; - -HOOK: ds-reg compiler-backend -HOOK: rs-reg compiler-backend -HOOK: stack-reg compiler-backend -HOOK: xt-reg compiler-backend -HOOK: stack-save-reg compiler-backend +HOOK: ds-reg cpu +HOOK: rs-reg cpu +HOOK: stack-reg cpu +HOOK: xt-reg cpu +HOOK: stack-save-reg cpu : stack@ stack-reg swap [+] ; @@ -24,7 +22,11 @@ M: rs-loc v>operand rs-loc-n rs-reg reg-stack ; M: int-regs %save-param-reg drop >r stack@ r> MOV ; M: int-regs %load-param-reg drop swap stack@ MOV ; -: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ; +GENERIC: MOVSS/D ( dst src reg-class -- ) + +M: single-float-regs MOVSS/D drop MOVSS ; + +M: double-float-regs MOVSS/D drop MOVSD ; M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ; @@ -33,34 +35,34 @@ GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( stack@ reg-class -- ) GENERIC: store-return-reg ( stack@ reg-class -- ) -HOOK: address-operand compiler-backend ( address -- operand ) +HOOK: address-operand cpu ( address -- operand ) -HOOK: fixnum>slot@ compiler-backend +HOOK: fixnum>slot@ cpu -HOOK: prepare-division compiler-backend +HOOK: prepare-division cpu M: immediate load-literal v>operand swap v>operand MOV ; -M: x86-backend stack-frame ( n -- i ) +M: x86 stack-frame ( n -- i ) 3 cells + 16 align cell - ; -M: x86-backend %save-word-xt ( -- ) +M: x86 %save-word-xt ( -- ) xt-reg 0 MOV rc-absolute-cell rel-this ; : factor-area-size 4 cells ; -M: x86-backend %prologue ( n -- ) +M: x86 %prologue ( n -- ) dup cell + PUSH xt-reg PUSH stack-reg swap 2 cells - SUB ; -M: x86-backend %epilogue ( n -- ) +M: x86 %epilogue ( n -- ) stack-reg swap ADD ; : %alien-global ( symbol dll register -- ) [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ; -M: x86-backend %prepare-alien-invoke +M: x86 %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. @@ -70,11 +72,11 @@ M: x86-backend %prepare-alien-invoke temp-reg v>operand 2 cells [+] ds-reg MOV temp-reg v>operand 3 cells [+] rs-reg MOV ; -M: x86-backend %call ( label -- ) CALL ; +M: x86 %call ( label -- ) CALL ; -M: x86-backend %jump-label ( label -- ) JMP ; +M: x86 %jump-label ( label -- ) JMP ; -M: x86-backend %jump-t ( label -- ) +M: x86 %jump-t ( label -- ) "flag" operand f v>operand CMP JNE ; : code-alignment ( -- n ) @@ -83,7 +85,7 @@ M: x86-backend %jump-t ( label -- ) : align-code ( n -- ) 0 % ; -M: x86-backend %dispatch ( -- ) +M: x86 %dispatch ( -- ) [ %epilogue-later ! Load jump table base. We use a temporary register @@ -105,27 +107,27 @@ M: x86-backend %dispatch ( -- ) { +clobber+ { "n" } } } with-template ; -M: x86-backend %dispatch-label ( word -- ) +M: x86 %dispatch-label ( word -- ) 0 cell, rc-absolute-cell rel-word ; -M: x86-backend %unbox-float ( dst src -- ) +M: x86 %unbox-float ( dst src -- ) [ v>operand ] bi@ float-offset [+] MOVSD ; -M: x86-backend %peek [ v>operand ] bi@ MOV ; +M: x86 %peek [ v>operand ] bi@ MOV ; -M: x86-backend %replace swap %peek ; +M: x86 %replace swap %peek ; : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; -M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ; +M: x86 %inc-d ( n -- ) ds-reg (%inc) ; -M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ; +M: x86 %inc-r ( n -- ) rs-reg (%inc) ; -M: x86-backend fp-shadows-int? ( -- ? ) f ; +M: x86 fp-shadows-int? ( -- ? ) f ; -M: x86-backend value-structs? t ; +M: x86 value-structs? t ; -M: x86-backend small-enough? ( n -- ? ) +M: x86 small-enough? ( n -- ? ) HEX: -80000000 HEX: 7fffffff between? ; : %untag ( reg -- ) tag-mask get bitnot AND ; @@ -143,34 +145,34 @@ M: x86-backend small-enough? ( n -- ? ) \ stack-frame get swap - ] ?if ; -HOOK: %unbox-struct-1 compiler-backend ( -- ) +HOOK: %unbox-struct-1 cpu ( -- ) -HOOK: %unbox-struct-2 compiler-backend ( -- ) +HOOK: %unbox-struct-2 cpu ( -- ) -M: x86-backend %unbox-small-struct ( size -- ) +M: x86 %unbox-small-struct ( size -- ) #! Alien must be in EAX. cell align cell /i { { 1 [ %unbox-struct-1 ] } { 2 [ %unbox-struct-2 ] } } case ; -M: x86-backend struct-small-enough? ( size -- ? ) +M: x86 struct-small-enough? ( size -- ? ) { 1 2 4 8 } member? - os { "linux" "netbsd" "solaris" } member? not and ; + os { linux netbsd solaris } member? not and ; -M: x86-backend %return ( -- ) 0 %unwind ; +M: x86 %return ( -- ) 0 %unwind ; ! Alien intrinsics -M: x86-backend %unbox-byte-array ( dst src -- ) +M: x86 %unbox-byte-array ( dst src -- ) [ v>operand ] bi@ byte-array-offset [+] LEA ; -M: x86-backend %unbox-alien ( dst src -- ) +M: x86 %unbox-alien ( dst src -- ) [ v>operand ] bi@ alien-offset [+] MOV ; -M: x86-backend %unbox-f ( dst src -- ) +M: x86 %unbox-f ( dst src -- ) drop v>operand 0 MOV ; -M: x86-backend %unbox-any-c-ptr ( dst src -- ) +M: x86 %unbox-any-c-ptr ( dst src -- ) { "is-byte-array" "end" "start" } [ define-label ] each ! Address is computed in ds-reg ds-reg PUSH diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 261ada025b..80a786c9fa 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics { +output+ { "in" } } } define-intrinsic -\ type [ - "end" define-label - ! Make a copy - "x" operand "obj" operand MOV - ! Get the tag - "x" operand tag-mask get AND - ! Tag the tag - "x" operand %tag-fixnum - ! Compare with object tag number (3). - "x" operand object tag-number tag-fixnum CMP - "end" get JNE - ! If we have equality, load type from header - "x" operand "obj" operand -3 [+] MOV - "end" resolve-label -] H{ - { +input+ { { f "obj" } } } - { +scratch+ { { f "x" } } } - { +output+ { "x" } } -} define-intrinsic - -\ class-hash [ - "end" define-label - "tuple" define-label - "object" define-label - ! Make a copy - "x" operand "obj" operand MOV - ! Get the tag - "x" operand tag-mask get AND - ! Tag the tag - "x" operand %tag-fixnum - ! Compare with tuple tag number (2). - "x" operand tuple tag-number tag-fixnum CMP - "tuple" get JE - ! Compare with object tag number (3). - "x" operand object tag-number tag-fixnum CMP - "object" get JE - "end" get JMP - "object" get resolve-label - ! Load header type - "x" operand "obj" operand header-offset [+] MOV - "end" get JMP - "tuple" get resolve-label - ! Load class hash - "x" operand "obj" operand tuple-class-offset [+] MOV - "x" operand dup class-hash-offset [+] MOV - "end" resolve-label -] H{ - { +input+ { { f "obj" } } } - { +scratch+ { { f "x" } } } - { +output+ { "x" } } -} define-intrinsic - ! Slots : %slot-literal-known-tag "obj" operand diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index f8b53d4abc..ca6aa59cc4 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -1,6 +1,7 @@ USING: alien arrays generic generic.math help.markup help.syntax kernel math memory strings sbufs vectors io io.files classes -help generic.standard continuations system debugger.private ; +help generic.standard continuations system debugger.private +io.files.private ; IN: debugger ARTICLE: "errors-assert" "Assertions" diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 033ae0680c..071535a01e 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -4,9 +4,9 @@ USING: arrays definitions generic hashtables inspector io kernel math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser classes.tuple continuations continuations.private combinators -generic.math io.streams.duplex classes compiler.units -generic.standard vocabs threads threads.private init -kernel.private libc io.encodings ; +generic.math io.streams.duplex classes.builtin classes +compiler.units generic.standard vocabs threads threads.private +init kernel.private libc io.encodings accessors ; IN: debugger GENERIC: error. ( error -- ) @@ -202,6 +202,12 @@ M: no-method error. M: no-math-method summary drop "No suitable arithmetic method" ; +M: no-next-method summary + drop "Executing call-next-method from least-specific method" ; + +M: inconsistent-next-method summary + drop "Executing call-next-method with inconsistent parameters" ; + M: stream-closed-twice summary drop "Attempt to perform I/O on closed stream" ; @@ -223,9 +229,11 @@ M: slice-error error. M: bounds-error summary drop "Sequence index out of bounds" ; -M: condition error. delegate error. ; +M: condition error. error>> error. ; -M: condition error-help drop f ; +M: condition summary error>> summary ; + +M: condition error-help error>> error-help ; M: assert summary drop "Assertion failed" ; diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index d855a14be9..d43c61ff70 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -12,8 +12,6 @@ $nl { $subsection forget } "Definitions can answer a sequence of definitions they directly depend on:" { $subsection uses } -"When a definition is changed, all definitions which depend on it are notified via a hook:" -{ $subsection redefined* } "Definitions must implement a few operations used for printing them in source form:" { $subsection synopsis* } { $subsection definer } @@ -108,11 +106,6 @@ HELP: usage { $description "Outputs a sequence of definitions that directly call the given definition." } { $notes "The sequence might include the definition itself, if it is a recursive word." } ; -HELP: redefined* -{ $values { "defspec" "a definition specifier" } } -{ $contract "Updates the definition to cope with a callee being redefined." } -$low-level-note ; - HELP: unxref { $values { "defspec" "a definition specifier" } } { $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." } diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index ebbce4d7e2..3dc28139ea 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -4,7 +4,7 @@ compiler.units words ; TUPLE: combination-1 ; -M: combination-1 perform-combination 2drop [ ] ; +M: combination-1 perform-combination drop [ ] define ; M: combination-1 make-default-method 2drop [ "No method" throw ] ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index cec5109909..6ee21fc016 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -42,13 +42,6 @@ M: object uses drop f ; : usage ( defspec -- seq ) \ f or crossref get at keys ; -GENERIC: redefined* ( defspec -- ) - -M: object redefined* drop ; - -: redefined ( defspec -- ) - [ crossref get at ] closure [ drop redefined* ] assoc-each ; - : unxref ( defspec -- ) dup uses crossref get remove-vertex ; diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 7581377a6a..5cc0442464 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -111,7 +111,7 @@ SYMBOL: literal-table : add-literal ( obj -- n ) literal-table get push-new* ; : string>symbol ( str -- alien ) - [ wince? [ string>u16-alien ] [ string>char-alien ] if ] + [ os wince? [ string>u16-alien ] [ string>char-alien ] if ] over string? [ call ] [ map ] if ; : add-dlsym-literals ( symbol dll -- ) diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index aac1b2cdc6..b5b3f0b2c0 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -3,7 +3,8 @@ USING: arrays assocs classes classes.private classes.algebra combinators cpu.architecture generator.fixup hashtables kernel layouts math namespaces quotations sequences system vectors -words effects alien byte-arrays bit-arrays float-arrays ; +words effects alien byte-arrays bit-arrays float-arrays +accessors ; IN: generator.registers SYMBOL: +input+ @@ -13,9 +14,11 @@ SYMBOL: +clobber+ SYMBOL: known-tag ! Register classes -TUPLE: int-regs ; - -TUPLE: float-regs size ; +SINGLETON: int-regs +SINGLETON: single-float-regs +SINGLETON: double-float-regs +UNION: float-regs single-float-regs double-float-regs ; +UNION: reg-class int-regs float-regs ; ( n reg-class -- vreg ) - { set-vreg-n set-delegate } vreg construct ; +C: vreg ( n reg-class -- vreg ) -M: vreg v>operand dup vreg-n swap vregs nth ; +M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ; M: vreg live-vregs* , ; +M: vreg move-spec reg-class>> move-spec ; INSTANCE: vreg value @@ -62,9 +65,9 @@ M: float-regs move-spec drop float ; M: float-regs operand-class* drop float ; ! Temporary register for stack shuffling -TUPLE: temp-reg ; +TUPLE: temp-reg reg-class>> ; -: temp-reg T{ temp-reg T{ int-regs } } ; +: temp-reg T{ temp-reg f int-regs } ; M: temp-reg move-spec drop f ; @@ -73,7 +76,7 @@ INSTANCE: temp-reg value ! A data stack location. TUPLE: ds-loc n class ; -: { set-ds-loc-n } ds-loc construct ; +: f ds-loc construct-boa ; M: ds-loc minimal-ds-loc* ds-loc-n min ; M: ds-loc operand-class* ds-loc-class ; @@ -84,8 +87,7 @@ M: ds-loc live-loc? ! A retain stack location. TUPLE: rs-loc n class ; -: { set-rs-loc-n } rs-loc construct ; - +: f rs-loc construct-boa ; M: rs-loc operand-class* rs-loc-class ; M: rs-loc set-operand-class set-rs-loc-class ; M: rs-loc live-loc? @@ -126,7 +128,7 @@ INSTANCE: cached value TUPLE: tagged vreg class ; : ( vreg -- tagged ) - { set-tagged-vreg } tagged construct ; + f tagged construct-boa ; M: tagged v>operand tagged-vreg v>operand ; M: tagged set-operand-class set-tagged-class ; @@ -228,48 +230,44 @@ INSTANCE: constant value } case ; ! A compile-time stack -TUPLE: phantom-stack height ; +TUPLE: phantom-stack height stack ; + +M: phantom-stack clone + call-next-method [ clone ] change-stack ; GENERIC: finalize-height ( stack -- ) -SYMBOL: phantom-d -SYMBOL: phantom-r - -: ( class -- stack ) - >r - V{ } clone 0 - { set-delegate set-phantom-stack-height } - phantom-stack construct - r> construct-delegate ; +: construct-phantom-stack ( class -- stack ) + >r 0 V{ } clone r> construct-boa ; inline : (loc) #! Utility for methods on - phantom-stack-height - ; + height>> - ; : (finalize-height) ( stack word -- ) #! We consolidate multiple stack height changes until the #! last moment, and we emit the final height changing #! instruction here. - swap [ - phantom-stack-height - dup zero? [ 2drop ] [ swap execute ] if - 0 - ] keep set-phantom-stack-height ; inline + [ + over zero? [ 2drop ] [ execute ] if 0 + ] curry change-height drop ; inline GENERIC: ( n stack -- loc ) -TUPLE: phantom-datastack ; +TUPLE: phantom-datastack < phantom-stack ; -: phantom-datastack ; +: ( -- stack ) + phantom-datastack construct-phantom-stack ; M: phantom-datastack (loc) ; M: phantom-datastack finalize-height \ %inc-d (finalize-height) ; -TUPLE: phantom-retainstack ; +TUPLE: phantom-retainstack < phantom-stack ; -: phantom-retainstack ; +: ( -- stack ) + phantom-retainstack construct-phantom-stack ; M: phantom-retainstack (loc) ; @@ -281,34 +279,33 @@ M: phantom-retainstack finalize-height >r r> [ ] curry map ; : phantom-locs* ( phantom -- locs ) - dup length swap phantom-locs ; + [ stack>> length ] keep phantom-locs ; + +: phantoms ( -- phantom phantom ) + phantom-datastack get phantom-retainstack get ; : (each-loc) ( phantom quot -- ) - >r dup phantom-locs* swap r> 2each ; inline + >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline : each-loc ( quot -- ) - >r phantom-d get r> phantom-r get over - >r >r (each-loc) r> r> (each-loc) ; inline + phantoms 2array swap [ (each-loc) ] curry each ; inline : adjust-phantom ( n phantom -- ) - [ phantom-stack-height + ] keep set-phantom-stack-height ; + swap [ + ] curry change-height drop ; -GENERIC: cut-phantom ( n phantom -- seq ) - -M: phantom-stack cut-phantom - [ delegate swap cut* swap ] keep set-delegate ; +: cut-phantom ( n phantom -- seq ) + swap [ cut* swap ] curry change-stack drop ; : phantom-append ( seq stack -- ) - over length over adjust-phantom push-all ; + over length over adjust-phantom stack>> push-all ; : add-locs ( n phantom -- ) - 2dup length <= [ + 2dup stack>> length <= [ 2drop ] [ [ phantom-locs ] keep - [ length head-slice* ] keep - [ append >vector ] keep - delegate set-delegate + [ stack>> length head-slice* ] keep + [ append >vector ] change-stack drop ] if ; : phantom-input ( n phantom -- seq ) @@ -316,18 +313,16 @@ M: phantom-stack cut-phantom 2dup cut-phantom >r >r neg r> adjust-phantom r> ; -: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ; - : each-phantom ( quot -- ) phantoms rot bi@ ; inline : finalize-heights ( -- ) [ finalize-height ] each-phantom ; : live-vregs ( -- seq ) - [ [ [ live-vregs* ] each ] each-phantom ] { } make ; + [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ; : (live-locs) ( phantom -- seq ) #! Discard locs which haven't moved - dup phantom-locs* swap 2array flip + [ phantom-locs* ] [ stack>> ] bi 2array flip [ live-loc? ] assoc-subset values ; @@ -340,15 +335,14 @@ SYMBOL: fresh-objects ! Computing free registers and initializing allocator : reg-spec>class ( spec -- class ) - float eq? - T{ float-regs f 8 } T{ int-regs } ? ; + float eq? double-float-regs int-regs ? ; : free-vregs ( reg-class -- seq ) #! Free vregs in a given register class \ free-vregs get at ; : alloc-vreg ( spec -- reg ) - dup reg-spec>class free-vregs pop swap { + [ reg-spec>class free-vregs pop ] keep { { f [ ] } { unboxed-alien [ ] } { unboxed-byte-array [ ] } @@ -374,8 +368,8 @@ SYMBOL: fresh-objects } cond ; : alloc-vreg-for ( value spec -- vreg ) - swap operand-class swap alloc-vreg - dup tagged? [ tuck set-tagged-class ] [ nip ] if ; + alloc-vreg swap operand-class + over tagged? [ >>class ] [ drop ] if ; M: value (lazy-load) 2dup allocation [ @@ -393,7 +387,7 @@ M: value (lazy-load) : compute-free-vregs ( -- ) #! Create a new hashtable for thee free-vregs variable. live-vregs - { T{ int-regs } T{ float-regs f 8 } } + { int-regs double-float-regs } [ 2dup (compute-free-vregs) ] H{ } map>assoc \ free-vregs set drop ; @@ -418,7 +412,7 @@ M: loc lazy-store #! When shuffling more values than can fit in registers, we #! need to find an area on the data stack which isn't in #! use. - dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ; + [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ; : find-tmp-loc ( -- n ) #! Find an area of the data stack which is not referenced @@ -442,7 +436,7 @@ M: loc lazy-store : fast-shuffle? ( live-locs -- ? ) #! Test if we have enough free registers to load all #! shuffle inputs at once. - T{ int-regs } free-vregs [ length ] bi@ <= ; + int-regs free-vregs [ length ] bi@ <= ; : finalize-locs ( -- ) #! Perform any deferred stack shuffling. @@ -462,13 +456,13 @@ M: loc lazy-store #! Kill register assignments but preserve constants and #! class information. dup phantom-locs* - over [ + over stack>> [ dup constant? [ nip ] [ operand-class over set-operand-class ] if ] 2map - over delete-all - swap push-all ; + over stack>> delete-all + swap stack>> push-all ; : reset-phantoms ( -- ) [ reset-phantom ] each-phantom ; @@ -483,10 +477,11 @@ M: loc lazy-store ! Loading stacks to vregs : free-vregs? ( int# float# -- ? ) - T{ float-regs f 8 } free-vregs length <= - >r T{ int-regs } free-vregs length <= r> and ; + double-float-regs free-vregs length <= + >r int-regs free-vregs length <= r> and ; : phantom&spec ( phantom spec -- phantom' spec' ) + >r stack>> r> [ length f pad-left ] keep [ ] bi@ ; inline @@ -504,7 +499,7 @@ M: loc lazy-store : substitute-vregs ( values vregs -- ) [ vreg-substitution ] 2map [ substitute-vreg? ] assoc-subset >hashtable - [ substitute-here ] curry each-phantom ; + [ >r stack>> r> substitute-here ] curry each-phantom ; : set-operand ( value var -- ) >r dup constant? [ constant-value ] when r> set ; @@ -516,14 +511,15 @@ M: loc lazy-store substitute-vregs ; : load-inputs ( -- ) - +input+ get dup length phantom-d get phantom-input - swap lazy-load ; + +input+ get + [ length phantom-datastack get phantom-input ] keep + lazy-load ; : output-vregs ( -- seq seq ) +output+ +clobber+ [ get [ get ] map ] bi@ ; : clash? ( seq -- ? ) - phantoms append [ + phantoms [ stack>> ] bi@ append [ dup cached? [ cached-vreg ] when swap member? ] with contains? ; @@ -534,22 +530,21 @@ M: loc lazy-store : count-input-vregs ( phantom spec -- ) phantom&spec [ - >r dup cached? [ cached-vreg ] when r> allocation + >r dup cached? [ cached-vreg ] when r> first allocation ] 2map count-vregs ; : count-scratch-regs ( spec -- ) [ first reg-spec>class ] map count-vregs ; : guess-vregs ( dinput rinput scratch -- int# float# ) - H{ - { T{ int-regs } 0 } - { T{ float-regs 8 } 0 } - } clone [ + [ + 0 int-regs set + 0 double-float-regs set count-scratch-regs - phantom-r get swap count-input-vregs - phantom-d get swap count-input-vregs - T{ int-regs } get T{ float-regs 8 } get - ] bind ; + phantom-retainstack get swap count-input-vregs + phantom-datastack get swap count-input-vregs + int-regs get double-float-regs get + ] with-scope ; : alloc-scratch ( -- ) +scratch+ get [ >r alloc-vreg r> set ] assoc-each ; @@ -566,7 +561,7 @@ M: loc lazy-store outputs-clash? [ finalize-contents ] when ; : template-outputs ( -- ) - +output+ get [ get ] map phantom-d get phantom-append ; + +output+ get [ get ] map phantom-datastack get phantom-append ; : value-matches? ( value spec -- ? ) #! If the spec is a quotation and the value is a literal @@ -581,12 +576,6 @@ M: loc lazy-store 2drop t ] if ; -: class-tags ( class -- tag/f ) - class-types [ - dup num-tags get >= - [ drop object tag-number ] when - ] map prune ; - : class-tag ( class -- tag/f ) class-tags dup length 1 = [ first ] [ drop f ] if ; @@ -602,7 +591,7 @@ M: loc lazy-store >r >r operand-class 2 r> ?nth class-matches? r> and ; : template-matches? ( spec -- ? ) - phantom-d get +input+ rot at + phantom-datastack get +input+ rot at [ spec-matches? ] phantom&spec-agree? ; : ensure-template-vregs ( -- ) @@ -611,14 +600,14 @@ M: loc lazy-store ] unless ; : clear-phantoms ( -- ) - [ delete-all ] each-phantom ; + [ stack>> delete-all ] each-phantom ; PRIVATE> : set-operand-classes ( classes -- ) - phantom-d get + phantom-datastack get over length over add-locs - [ set-operand-class ] 2reverse-each ; + stack>> [ set-operand-class ] 2reverse-each ; : end-basic-block ( -- ) #! Commit all deferred stacking shuffling, and ensure the @@ -627,7 +616,7 @@ PRIVATE> finalize-contents clear-phantoms finalize-heights - fresh-objects get dup empty? swap delete-all [ %gc ] unless ; + fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ; : with-template ( quot hash -- ) clone [ @@ -647,16 +636,16 @@ PRIVATE> : init-templates ( -- ) #! Initialize register allocator. V{ } clone fresh-objects set - phantom-d set - phantom-r set + phantom-datastack set + phantom-retainstack set compute-free-vregs ; : copy-templates ( -- ) #! Copies register allocator state, used when compiling #! branches. fresh-objects [ clone ] change - phantom-d [ clone ] change - phantom-r [ clone ] change + phantom-datastack [ clone ] change + phantom-retainstack [ clone ] change compute-free-vregs ; : find-template ( templates -- pair/f ) @@ -672,17 +661,17 @@ UNION: immediate fixnum POSTPONE: f ; operand-class immediate class< ; : phantom-push ( obj -- ) - 1 phantom-d get adjust-phantom - phantom-d get push ; + 1 phantom-datastack get adjust-phantom + phantom-datastack get stack>> push ; : phantom-shuffle ( shuffle -- ) - [ effect-in length phantom-d get phantom-input ] keep - shuffle* phantom-d get phantom-append ; + [ effect-in length phantom-datastack get phantom-input ] keep + shuffle* phantom-datastack get phantom-append ; : phantom->r ( n -- ) - phantom-d get phantom-input - phantom-r get phantom-append ; + phantom-datastack get phantom-input + phantom-retainstack get phantom-append ; : phantom-r> ( n -- ) - phantom-r get phantom-input - phantom-d get phantom-append ; + phantom-retainstack get phantom-input + phantom-datastack get phantom-append ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 56de801e7a..1024c377a8 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -37,7 +37,8 @@ $nl { $subsection create-method } "Method definitions can be looked up:" { $subsection method } -{ $subsection methods } +"Finding the most specific method for an object:" +{ $subsection effective-method } "A generic word contains methods; the list of methods specializing on a class can also be obtained:" { $subsection implementors } "Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:" @@ -63,17 +64,21 @@ ARTICLE: "method-combination" "Custom method combination" "Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the definition protocol words " { $link definer } " and " { $link synopsis* } " on the class of words having this method combination, to properly support developer tools." $nl "The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation." -$nl -"Method combination utilities:" -{ $subsection single-combination } -{ $subsection class-predicates } -{ $subsection simplify-alist } -{ $subsection math-upgrade } -{ $subsection object-method } -{ $subsection error-method } -"More quotation construction utilities can be found in " { $link "quotations" } " and " { $link "combinators-quot" } "." { $see-also "generic-introspection" } ; +ARTICLE: "call-next-method" "Calling less-specific methods" +"If a generic word is called with an object and multiple methods specialize on classes that this object is an instance of, usually the most specific method is called (" { $link "method-order" } ")." +$nl +"Less-specific methods can be called directly:" +{ $subsection POSTPONE: call-next-method } +"A lower-level word which the above expands into:" +{ $subsection (call-next-method) } +"To look up the next applicable method reflectively:" +{ $subsection next-method } +"Errors thrown by improper calls to " { $link POSTPONE: call-next-method } ":" +{ $subsection inconsistent-next-method } +{ $subsection no-next-method } ; + ARTICLE: "generic" "Generic words and methods" "A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition." $nl @@ -91,6 +96,7 @@ $nl { $subsection POSTPONE: M: } "Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "." { $subsection "method-order" } +{ $subsection "call-next-method" } { $subsection "generic-introspection" } { $subsection "method-combination" } "Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ; @@ -129,10 +135,6 @@ HELP: { $values { "class" class } { "generic" generic } { "method" "a new method definition" } } { $description "Creates a new method." } ; -HELP: methods -{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } -{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ; - HELP: order { $values { "generic" generic } { "seq" "a sequence of classes" } } { $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ; @@ -160,4 +162,9 @@ HELP: forget-methods { $values { "class" class } } { $description "Remove all method definitions which specialize on the class." } ; -{ sort-classes methods order } related-words +{ sort-classes order } related-words + +HELP: (call-next-method) +{ $values { "class" class } { "generic" generic } } +{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." } +{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 6a7f8f29fc..524835f461 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -21,19 +21,6 @@ M: word class-of drop "word" ; [ "Hello world" ] [ 4 foobar foobar ] unit-test [ "Goodbye cruel world" ] [ 4 foobar ] unit-test -GENERIC: bool>str ( x -- y ) -M: general-t bool>str drop "true" ; -M: f bool>str drop "false" ; - -: str>bool - H{ - { "true" t } - { "false" f } - } at ; - -[ t ] [ t bool>str str>bool ] unit-test -[ f ] [ f bool>str str>bool ] unit-test - ! Testing unions UNION: funnies quotation float complex ; @@ -51,16 +38,6 @@ M: very-funny gooey sq ; [ 0.25 ] [ 0.5 gooey ] unit-test -DEFER: complement-test -FORGET: complement-test -GENERIC: complement-test ( x -- y ) - -M: f complement-test drop "f" ; -M: general-t complement-test drop "general-t" ; - -[ "general-t" ] [ 5 complement-test ] unit-test -[ "f" ] [ f complement-test ] unit-test - GENERIC: empty-method-test ( x -- y ) M: object empty-method-test ; TUPLE: for-arguments-sake ; @@ -171,37 +148,6 @@ M: f tag-and-f 4 ; [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test -! define-class hashing issue -TUPLE: debug-combination ; - -M: debug-combination make-default-method - 2drop [ "Oops" throw ] ; - -M: debug-combination perform-combination - drop - order [ dup class-hashes ] { } map>assoc sort-keys - 1quotation ; - -SYMBOL: redefinition-test-generic - -[ - redefinition-test-generic - T{ debug-combination } - define-generic -] with-compilation-unit - -TUPLE: redefinition-test-tuple ; - -"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval - -[ t ] [ - [ - redefinition-test-generic , - "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval - redefinition-test-generic , - ] { } make all-equal? -] unit-test - ! Issues with forget GENERIC: generic-forget-test-1 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 7dba7eb709..f41f3ebcd0 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -6,16 +6,7 @@ classes.algebra quotations arrays vocabs effects ; IN: generic ! Method combination protocol -GENERIC: perform-combination ( word combination -- quot ) - -M: object perform-combination - #! We delay the invalid method combination error for a - #! reason. If we call forget-vocab on a vocabulary which - #! defines a method combination, a generic using this - #! method combination, and a method on the generic, and the - #! method combination is forgotten first, then forgetting - #! the method will throw an error. We don't want that. - nip [ "Invalid method combination" throw ] curry [ ] like ; +GENERIC: perform-combination ( word combination -- ) GENERIC: make-default-method ( generic combination -- method ) @@ -25,8 +16,9 @@ PREDICATE: generic < word M: generic definition drop f ; : make-generic ( word -- ) - dup { "unannotated-def" } reset-props - dup dup "combination" word-prop perform-combination define ; + [ { "unannotated-def" } reset-props ] + [ dup "combination" word-prop perform-combination ] + bi ; : method ( class generic -- method/f ) "methods" word-prop at ; @@ -37,10 +29,19 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; -: methods ( word -- assoc ) - "methods" word-prop - [ keys sort-classes ] keep - [ dupd at ] curry { } map>assoc ; +GENERIC: effective-method ( ... generic -- method ) + +: next-method-class ( class generic -- class/f ) + order [ class< ] with subset reverse dup length 1 = + [ drop f ] [ second ] if ; + +: next-method ( class generic -- class/f ) + [ next-method-class ] keep method ; + +GENERIC: next-method-quot ( class generic -- quot ) + +: (call-next-method) ( class generic -- ) + next-method-quot call ; TUPLE: check-method class generic ; @@ -62,6 +63,9 @@ PREDICATE: method-body < word M: method-body stack-effect "method-generic" word-prop stack-effect ; +M: method-body crossref? + drop t ; + : method-word-props ( class generic -- assoc ) [ "method-generic" set @@ -104,14 +108,6 @@ M: method-spec definer M: method-spec definition first2 method definition ; -: forget-method ( class generic -- ) - dup generic? [ - [ delete-at* ] with-methods - [ forget-word ] [ drop ] if - ] [ - 2drop - ] if ; - M: method-spec forget* first2 method forget* ; @@ -120,9 +116,15 @@ M: method-body definer M: method-body forget* dup "forgotten" word-prop [ drop ] [ - dup "method-class" word-prop - over "method-generic" word-prop forget-method - t "forgotten" set-word-prop + [ + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + dup generic? [ + [ delete-at* ] with-methods + [ call-next-method ] [ drop ] if + ] [ 2drop ] if + ] + [ t "forgotten" set-word-prop ] bi ] if ; : implementors* ( classes -- words ) @@ -135,12 +137,13 @@ M: method-body forget* dup associate implementors* ; : forget-methods ( class -- ) - [ implementors ] keep [ swap 2array ] curry map forget-all ; + [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; M: class forget* ( class -- ) - dup forget-methods - dup update-map- - forget-word ; + [ forget-methods ] + [ update-map- ] + [ call-next-method ] + tri ; M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; @@ -156,11 +159,15 @@ M: assoc update-methods ( assoc -- ) ] if ; M: generic subwords - dup "methods" word-prop values - swap "default-method" word-prop suffix ; + [ + [ "default-method" word-prop , ] + [ "methods" word-prop values % ] + [ "engines" word-prop % ] + tri + ] { } make ; -M: generic forget-word - dup subwords [ forget ] each (forget-word) ; +M: generic forget* + [ subwords forget-all ] [ call-next-method ] bi ; : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 85bd736139..fce908bdef 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math namespaces sequences words quotations layouts combinators -sequences.private classes classes.algebra definitions ; +sequences.private classes classes.builtin classes.algebra +definitions ; IN: generic.math PREDICATE: math-class < class @@ -12,9 +13,9 @@ PREDICATE: math-class < class number bootstrap-word class< ] if ; -: last/first ( seq -- pair ) dup peek swap first 2array ; +: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ; -: math-precedence ( class -- n ) +: math-precedence ( class -- pair ) { { [ dup null class< ] [ drop { -1 -1 } ] } { [ dup math-class? ] [ class-types last/first ] } @@ -71,13 +72,15 @@ M: math-combination make-default-method M: math-combination perform-combination drop + dup \ over [ dup math-class? [ \ dup [ >r 2dup r> math-method ] math-vtable ] [ over object-method ] if nip - ] math-vtable nip ; + ] math-vtable nip + define ; PREDICATE: math-generic < generic ( word -- ? ) "combination" word-prop math-combination? ; diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor new file mode 100644 index 0000000000..bf8d4fb67a --- /dev/null +++ b/core/generic/standard/engines/engines.factor @@ -0,0 +1,49 @@ +USING: assocs kernel namespaces quotations generic math +sequences combinators words classes.algebra ; +IN: generic.standard.engines + +SYMBOL: default +SYMBOL: assumed + +GENERIC: engine>quot ( engine -- quot ) + +M: quotation engine>quot ; + +M: method-body engine>quot 1quotation ; + +: engines>quots ( assoc -- assoc' ) + [ engine>quot ] assoc-map ; + +: engines>quots* ( assoc -- assoc' ) + [ over assumed [ engine>quot ] with-variable ] assoc-map ; + +: if-small? ( assoc true false -- ) + >r >r dup assoc-size 4 <= r> r> if ; inline + +: linear-dispatch-quot ( alist -- quot ) + default get [ drop ] prepend swap + [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map + alist>quot ; + +: split-methods ( assoc class -- first second ) + [ [ nip class< not ] curry assoc-subset ] + [ [ nip class< ] curry assoc-subset ] 2bi ; + +: convert-methods ( assoc class word -- assoc' ) + over >r >r split-methods dup assoc-empty? [ + r> r> 3drop + ] [ + r> execute r> pick set-at + ] if ; inline + +SYMBOL: (dispatch#) + +: (picker) ( n -- quot ) + { + { 0 [ [ dup ] ] } + { 1 [ [ over ] ] } + { 2 [ [ pick ] ] } + [ 1- (picker) [ >r ] swap [ r> swap ] 3append ] + } case ; + +: picker ( -- quot ) \ (dispatch#) get (picker) ; diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor new file mode 100644 index 0000000000..ce7d5c6c21 --- /dev/null +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -0,0 +1,32 @@ +USING: generic.standard.engines generic namespaces kernel +sequences classes.algebra accessors words combinators +assocs ; +IN: generic.standard.engines.predicate + +TUPLE: predicate-dispatch-engine methods ; + +C: predicate-dispatch-engine + +: class-predicates ( assoc -- assoc ) + [ >r "predicate" word-prop picker prepend r> ] assoc-map ; + +: keep-going? ( assoc -- ? ) + assumed get swap second first class< ; + +: prune-redundant-predicates ( assoc -- default assoc' ) + { + { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } + { [ dup length 1 = ] [ first second { } ] } + { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] } + { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] } + } cond ; + +: sort-methods ( assoc -- assoc' ) + [ keys sort-classes ] + [ [ dupd at ] curry ] bi { } map>assoc ; + +M: predicate-dispatch-engine engine>quot + methods>> clone + default get object bootstrap-word pick set-at engines>quots + sort-methods prune-redundant-predicates + class-predicates alist>quot ; diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor new file mode 100644 index 0000000000..6344bec536 --- /dev/null +++ b/core/generic/standard/engines/tag/tag.factor @@ -0,0 +1,57 @@ +USING: classes.private generic.standard.engines namespaces +arrays assocs sequences.private quotations kernel.private +math slots.private math.private kernel accessors words +layouts ; +IN: generic.standard.engines.tag + +TUPLE: lo-tag-dispatch-engine methods ; + +C: lo-tag-dispatch-engine + +: direct-dispatch-quot ( alist n -- quot ) + default get + [ swap update ] keep + [ dispatch ] curry >quotation ; + +: lo-tag-number ( class -- n ) + dup \ hi-tag bootstrap-word eq? [ + drop \ hi-tag tag-number + ] [ + "type" word-prop + ] if ; + +M: lo-tag-dispatch-engine engine>quot + methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map + [ + picker % [ tag ] % [ + linear-dispatch-quot + ] [ + num-tags get direct-dispatch-quot + ] if-small? % + ] [ ] make ; + +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ convert-methods ; + +: num-hi-tags num-types get num-tags get - ; + +: hi-tag-number ( class -- n ) + "type" word-prop num-tags get - ; + +: hi-tag-quot ( -- quot ) + [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ; + +M: hi-tag-dispatch-engine engine>quot + methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map + [ + picker % hi-tag-quot % [ + linear-dispatch-quot + ] [ + num-hi-tags direct-dispatch-quot + ] if-small? % + ] [ ] make ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor new file mode 100644 index 0000000000..40e749f473 --- /dev/null +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -0,0 +1,128 @@ +IN: generic.standard.engines.tuple +USING: kernel classes.tuple.private hashtables assocs sorting +accessors combinators sequences slots.private math.parser words +effects namespaces generic generic.standard.engines +classes.algebra math math.private quotations arrays ; + +TUPLE: echelon-dispatch-engine n methods ; + +C: echelon-dispatch-engine + +TUPLE: trivial-tuple-dispatch-engine methods ; + +C: trivial-tuple-dispatch-engine + +TUPLE: tuple-dispatch-engine echelons ; + +: push-echelon ( class method assoc -- ) + >r swap dup "layout" word-prop layout-echelon r> + [ ?set-at ] change-at ; + +: echelon-sort ( assoc -- assoc' ) + V{ } clone [ + [ + push-echelon + ] curry assoc-each + ] keep sort-keys ; + +: ( methods -- engine ) + echelon-sort + [ + over zero? [ + dup assoc-empty? + [ drop f ] [ values first ] if + ] [ + dupd + ] if + ] assoc-map [ nip ] assoc-subset + \ tuple-dispatch-engine construct-boa ; + +: convert-tuple-methods ( assoc -- assoc' ) + tuple bootstrap-word + \ convert-methods ; + +M: trivial-tuple-dispatch-engine engine>quot + methods>> engines>quots* linear-dispatch-quot ; + +: hash-methods ( methods -- buckets ) + >alist V{ } clone [ hashcode 1array ] distribute-buckets + [ ] map ; + +: class-hash-dispatch-quot ( methods -- quot ) + #! 1 slot == word hashcode + [ + [ dup 1 slot ] % + hash-methods [ engine>quot ] map hash-dispatch-quot % + ] [ ] make ; + +: tuple-dispatch-engine-word-name ( engine -- string ) + [ + generic get word-name % + "/tuple-dispatch-engine/" % + n>> # + ] "" make ; + +PREDICATE: tuple-dispatch-engine-word < word + "tuple-dispatch-engine" word-prop ; + +M: tuple-dispatch-engine-word stack-effect + "tuple-dispatch-generic" word-prop stack-effect ; + +M: tuple-dispatch-engine-word crossref? + drop t ; + +: remember-engine ( word -- ) + generic get "engines" word-prop push ; + +: ( engine -- word ) + tuple-dispatch-engine-word-name f + { + [ t "tuple-dispatch-engine" set-word-prop ] + [ generic get "tuple-dispatch-generic" set-word-prop ] + [ remember-engine ] + [ ] + } cleave ; + +: define-tuple-dispatch-engine-word ( engine quot -- word ) + >r dup r> define ; + +: tuple-dispatch-engine-body ( engine -- quot ) + #! 1 slot == tuple-layout + #! 2 slot == 0 array-nth + #! 4 slot == layout-superclasses + [ + picker % + [ 1 slot 4 slot ] % + [ n>> 2 + , [ slot ] % ] + [ + methods>> [ + engine>quot + ] [ + class-hash-dispatch-quot + ] if-small? % + ] bi + ] [ ] make ; + +M: echelon-dispatch-engine engine>quot + dup tuple-dispatch-engine-body + define-tuple-dispatch-engine-word + 1quotation ; + +: >=-case-quot ( alist -- quot ) + default get [ drop ] prepend swap + [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map + alist>quot ; + +M: tuple-dispatch-engine engine>quot + #! 1 slot == tuple-layout + #! 5 slot == layout-echelon + [ + picker % + [ 1 slot 5 slot ] % + echelons>> + [ + tuple assumed set + [ engine>quot dup default set ] assoc-map + ] with-scope + >=-case-quot % + ] [ ] make ; diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index a6a65bb62f..1d98dec87c 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,4 +1,5 @@ -USING: generic help.markup help.syntax sequences ; +USING: generic help.markup help.syntax sequences math +math.parser ; IN: generic.standard HELP: no-method @@ -10,7 +11,7 @@ HELP: standard-combination { $class-description "Performs standard method combination." $nl - "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. If no suitable method is defined on the class of the dispatch object, the generic word is called on the dispatch object's delegate. If the delegate is " { $link f } ", an exception is thrown." + "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. A " { $link no-method } " error is thrown if no suitable method is defined on the class." } { $examples "A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:" @@ -31,3 +32,38 @@ HELP: define-simple-generic { $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; { standard-combination hook-combination } related-words + +HELP: no-next-method +{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." } +{ $examples + "The following code throws this error:" + { $code + "GENERIC: error-test ( object -- )" + "" + "M: number error-test 3 + call-next-method ;" + "" + "M: integer error-test recip call-next-method ;" + "" + "123 error-test" + } + "This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown." +} ; + +HELP: inconsistent-next-method +{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } +{ $examples + "The following code throws this error:" + { $code + "GENERIC: error-test ( object -- )" + "" + "M: string error-test print ;" + "" + "M: integer error-test number>string call-next-method ;" + "" + "123 error-test" + } + "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." + $nl + "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" + { $code "M: integer error-test number>string error-test ;" } +} ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor new file mode 100644 index 0000000000..2f58770b1a --- /dev/null +++ b/core/generic/standard/standard-tests.factor @@ -0,0 +1,235 @@ +IN: generic.standard.tests +USING: tools.test math math.functions math.constants +generic.standard strings sequences arrays kernel accessors +words float-arrays byte-arrays bit-arrays parser namespaces ; + +GENERIC: lo-tag-test + +M: integer lo-tag-test 3 + ; + +M: float lo-tag-test 4 - ; + +M: rational lo-tag-test 2 - ; + +M: complex lo-tag-test sq ; + +[ 8 ] [ 5 >bignum lo-tag-test ] unit-test +[ 0.0 ] [ 4.0 lo-tag-test ] unit-test +[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test +[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test + +GENERIC: hi-tag-test + +M: string hi-tag-test ", in bed" append ; + +M: integer hi-tag-test 3 + ; + +M: array hi-tag-test [ hi-tag-test ] map ; + +M: sequence hi-tag-test reverse ; + +[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test + +[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test + +[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test + +TUPLE: shape ; + +TUPLE: abstract-rectangle < shape width height ; + +TUPLE: rectangle < abstract-rectangle ; + +C: rectangle + +TUPLE: parallelogram < abstract-rectangle skew ; + +C: parallelogram + +TUPLE: circle < shape radius ; + +C: circle + +GENERIC: area + +M: abstract-rectangle area [ width>> ] [ height>> ] bi * ; + +M: circle area radius>> sq pi * ; + +[ 12 ] [ 4 3 area ] unit-test +[ 12 ] [ 4 3 2 area ] unit-test +[ t ] [ 2 area 4 pi * = ] unit-test + +GENERIC: perimiter + +: rectangle-perimiter + 2 * ; + +M: rectangle perimiter + [ width>> ] [ height>> ] bi + rectangle-perimiter ; + +: hypotenuse [ sq ] bi@ + sqrt ; + +M: parallelogram perimiter + [ width>> ] + [ [ height>> ] [ skew>> ] bi hypotenuse ] bi + rectangle-perimiter ; + +M: circle perimiter 2 * pi * ; + +[ 14 ] [ 4 3 perimiter ] unit-test +[ 30 ] [ 10 4 3 perimiter ] unit-test + +GENERIC: big-mix-test + +M: object big-mix-test drop "object" ; + +M: tuple big-mix-test drop "tuple" ; + +M: integer big-mix-test drop "integer" ; + +M: float big-mix-test drop "float" ; + +M: complex big-mix-test drop "complex" ; + +M: string big-mix-test drop "string" ; + +M: array big-mix-test drop "array" ; + +M: sequence big-mix-test drop "sequence" ; + +M: rectangle big-mix-test drop "rectangle" ; + +M: parallelogram big-mix-test drop "parallelogram" ; + +M: circle big-mix-test drop "circle" ; + +[ "integer" ] [ 3 big-mix-test ] unit-test +[ "float" ] [ 5.0 big-mix-test ] unit-test +[ "complex" ] [ -1 sqrt big-mix-test ] unit-test +[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test +[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test +[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test +[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test +[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test +[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test +[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test +[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test +[ "string" ] [ "hello" big-mix-test ] unit-test +[ "rectangle" ] [ 1 2 big-mix-test ] unit-test +[ "parallelogram" ] [ 10 4 3 big-mix-test ] unit-test +[ "circle" ] [ 100 big-mix-test ] unit-test +[ "tuple" ] [ H{ } big-mix-test ] unit-test +[ "object" ] [ \ + big-mix-test ] unit-test + +GENERIC: small-lo-tag + +M: fixnum small-lo-tag drop "fixnum" ; + +M: string small-lo-tag drop "string" ; + +M: array small-lo-tag drop "array" ; + +M: float-array small-lo-tag drop "float-array" ; + +M: byte-array small-lo-tag drop "byte-array" ; + +[ "fixnum" ] [ 3 small-lo-tag ] unit-test + +[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test + +! Testing next-method +TUPLE: person ; + +TUPLE: intern < person ; + +TUPLE: employee < person ; + +TUPLE: tape-monkey < employee ; + +TUPLE: manager < employee ; + +TUPLE: junior-manager < manager ; + +TUPLE: middle-manager < manager ; + +TUPLE: senior-manager < manager ; + +TUPLE: executive < senior-manager ; + +TUPLE: ceo < executive ; + +GENERIC: salary ( person -- n ) + +M: intern salary + #! Intentional mistake. + call-next-method ; + +M: employee salary drop 24000 ; + +M: manager salary call-next-method 12000 + ; + +M: middle-manager salary call-next-method 5000 + ; + +M: senior-manager salary call-next-method 15000 + ; + +M: executive salary call-next-method 2 * ; + +M: ceo salary + #! Intentional error. + drop 5 call-next-method 3 * ; + +[ salary ] must-infer + +[ 24000 ] [ employee construct-boa salary ] unit-test + +[ 24000 ] [ tape-monkey construct-boa salary ] unit-test + +[ 36000 ] [ junior-manager construct-boa salary ] unit-test + +[ 41000 ] [ middle-manager construct-boa salary ] unit-test + +[ 51000 ] [ senior-manager construct-boa salary ] unit-test + +[ 102000 ] [ executive construct-boa salary ] unit-test + +[ ceo construct-boa salary ] +[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with + +[ intern construct-boa salary ] +[ T{ no-next-method f intern salary } = ] must-fail-with + +! Weird shit +TUPLE: a ; +TUPLE: b ; +TUPLE: c ; + +UNION: x a b ; +UNION: y a c ; + +UNION: z x y ; + +GENERIC: funky* ( obj -- ) + +M: z funky* "z" , drop ; + +M: x funky* "x" , call-next-method ; + +M: y funky* "y" , call-next-method ; + +M: a funky* "a" , call-next-method ; + +M: b funky* "b" , call-next-method ; + +M: c funky* "c" , call-next-method ; + +: funky [ funky* ] { } make ; + +[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test + +[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test + +[ t ] [ + T{ a } funky + { { "a" "x" "z" } { "a" "y" "z" } } member? +] unit-test diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor old mode 100755 new mode 100644 index 13b5278735..9f9a892fd4 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -3,32 +3,27 @@ USING: arrays assocs kernel kernel.private slots.private math namespaces sequences vectors words quotations definitions hashtables layouts combinators sequences.private generic -classes classes.algebra classes.private ; +classes classes.algebra classes.private generic.standard.engines +generic.standard.engines.tag generic.standard.engines.predicate +generic.standard.engines.tuple accessors ; IN: generic.standard -TUPLE: standard-combination # ; +GENERIC: dispatch# ( word -- n ) -C: standard-combination +M: word dispatch# "combination" word-prop dispatch# ; -SYMBOL: (dispatch#) - -: (picker) ( n -- quot ) +: unpickers { - { 0 [ [ dup ] ] } - { 1 [ [ over ] ] } - { 2 [ [ pick ] ] } - [ 1- (picker) [ >r ] swap [ r> swap ] 3append ] - } case ; - -: picker ( -- quot ) \ (dispatch#) get (picker) ; - -: unpickers { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } ; inline + [ nip ] + [ >r nip r> swap ] + [ >r >r nip r> r> -rot ] + } ; inline : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ; ERROR: no-method object generic ; -: error-method ( word -- quot ) +: error-method ( word -- quot ) picker swap [ no-method ] curry append ; : empty-method ( word -- quot ) @@ -38,159 +33,138 @@ ERROR: no-method object generic ; error-method \ drop prefix , \ if , ] [ ] make ; -: class-predicates ( assoc -- assoc ) - [ - >r >r picker r> "predicate" word-prop append r> - ] assoc-map ; - -: (simplify-alist) ( class i assoc -- default assoc ) - 2dup length 1- = [ - nth second { } rot drop - ] [ - 3dup >r 1+ r> nth first class< [ - >r 1+ r> (simplify-alist) - ] [ - [ nth second ] 2keep swap 1+ tail rot drop - ] if - ] if ; - -: simplify-alist ( class assoc -- default assoc ) - dup empty? [ - 2drop [ "Unreachable" throw ] { } - ] [ - 0 swap (simplify-alist) - ] if ; - : default-method ( word -- pair ) "default-method" word-prop object bootstrap-word swap 2array ; -: method-alist>quot ( alist base-class -- quot ) - bootstrap-word swap simplify-alist - class-predicates alist>quot ; - -: small-generic ( methods -- def ) - object method-alist>quot ; - -: hash-methods ( methods -- buckets ) - V{ } clone [ - tuple bootstrap-word over class< [ - drop t - ] [ - class-hashes - ] if - ] distribute-buckets ; - -: class-hash-dispatch-quot ( methods quot picker -- quot ) - >r >r hash-methods r> map - hash-dispatch-quot r> [ class-hash ] rot 3append ; inline - -: big-generic ( methods -- quot ) - [ small-generic ] picker class-hash-dispatch-quot ; - -: vtable-class ( n -- class ) - bootstrap-type>class [ hi-tag bootstrap-word ] unless* ; - -: group-methods ( assoc -- vtable ) - #! Input is a predicate -> method association. - #! n is vtable size (either num-types or num-tags). - num-tags get [ - vtable-class - [ swap first classes-intersect? ] curry subset - ] with map ; - -: build-type-vtable ( alist-seq -- alist-seq ) - dup length [ - vtable-class - swap simplify-alist - class-predicates alist>quot - ] 2map ; - -: tag-generic ( methods -- quot ) +: push-method ( method specializer atomic assoc -- ) [ - picker % - \ tag , - group-methods build-type-vtable , - \ dispatch , - ] [ ] make ; + [ H{ } clone ] unless* + [ methods>> set-at ] keep + ] change-at ; -: flatten-method ( class body -- ) - over members pick object bootstrap-word eq? not and [ - >r members r> [ flatten-method ] curry each - ] [ - swap set - ] if ; +: flatten-method ( class method assoc -- ) + >r >r dup flatten-class keys swap r> r> [ + >r spin r> push-method + ] 3curry each ; -: flatten-methods ( methods -- newmethods ) - [ [ flatten-method ] assoc-each ] V{ } make-assoc ; +: flatten-methods ( assoc -- assoc' ) + H{ } clone [ + [ + flatten-method + ] curry assoc-each + ] keep ; -: dispatched-types ( methods -- seq ) - keys object bootstrap-word swap remove prune ; +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; -: single-combination ( methods -- quot ) - dup length 4 <= [ - small-generic - ] [ - flatten-methods - dup dispatched-types [ number class< ] all? - [ tag-generic ] [ big-generic ] if - ] if ; +: find-default ( methods -- quot ) + #! Side-effects methods. + object bootstrap-word swap delete-at* [ + drop generic get "default-method" word-prop 1quotation + ] unless ; -: standard-methods ( word -- alist ) - dup methods swap default-method prefix - [ 1quotation ] assoc-map ; +GENERIC: mangle-method ( method generic -- quot ) -M: standard-combination make-default-method - standard-combination-# (dispatch#) - [ empty-method ] with-variable ; - -M: standard-combination perform-combination - standard-combination-# (dispatch#) [ - [ standard-methods ] keep "inline" word-prop - [ small-generic ] [ single-combination ] if - ] with-variable ; - -TUPLE: hook-combination var ; - -C: hook-combination - -: with-hook ( combination quot -- quot' ) - 0 (dispatch#) [ - swap slip - hook-combination-var [ get ] curry - prepend - ] with-variable ; inline - -M: hook-combination make-default-method - [ error-method ] with-hook ; - -M: hook-combination perform-combination +: single-combination ( word -- quot ) [ - standard-methods - [ [ drop ] prepend ] assoc-map - single-combination - ] with-hook ; + object bootstrap-word assumed set { + [ generic set ] + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] + [ + "methods" word-prop + [ generic get mangle-method ] assoc-map + [ find-default default set ] + [ + generic get "inline" word-prop [ + + ] [ + + ] if + ] bi + engine>quot + ] + } cleave + ] with-scope ; -: define-simple-generic ( word -- ) - T{ standard-combination f 0 } define-generic ; +TUPLE: standard-combination # ; + +C: standard-combination PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; PREDICATE: simple-generic < standard-generic - "combination" word-prop standard-combination-# zero? ; + "combination" word-prop #>> zero? ; + +: define-simple-generic ( word -- ) + T{ standard-combination f 0 } define-generic ; + +: with-standard ( combination quot -- quot' ) + >r #>> (dispatch#) r> with-variable ; inline + +M: standard-generic mangle-method + drop 1quotation ; + +M: standard-combination make-default-method + [ empty-method ] with-standard ; + +M: standard-combination perform-combination + [ drop ] [ [ single-combination ] with-standard ] 2bi define ; + +M: standard-combination dispatch# #>> ; + +M: standard-generic effective-method + [ dispatch# (picker) call ] keep + [ order [ instance? ] with find-last nip ] keep method ; + +ERROR: inconsistent-next-method object class generic ; + +ERROR: no-next-method class generic ; + +M: standard-generic next-method-quot + [ + [ + [ [ instance? ] curry ] + [ dispatch# (picker) ] bi* prepend % + ] + [ + 2dup next-method + [ 2nip 1quotation ] + [ [ no-next-method ] 2curry ] if* , + ] + [ [ inconsistent-next-method ] 2curry , ] + 2tri + \ if , + ] [ ] make ; + +TUPLE: hook-combination var ; + +C: hook-combination PREDICATE: hook-generic < generic "combination" word-prop hook-combination? ; -GENERIC: dispatch# ( word -- n ) - -M: word dispatch# "combination" word-prop dispatch# ; - -M: standard-combination dispatch# standard-combination-# ; +: with-hook ( combination quot -- quot' ) + 0 (dispatch#) [ + dip var>> [ get ] curry prepend + ] with-variable ; inline M: hook-combination dispatch# drop 0 ; +M: hook-generic mangle-method + drop 1quotation [ drop ] prepend ; + +M: hook-combination make-default-method + [ error-method ] with-hook ; + +M: hook-combination perform-combination + [ drop ] [ [ single-combination ] with-hook ] 2bi define ; + M: simple-generic definer drop \ GENERIC: f ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 77560c7444..b22d8818c1 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces tools.test -heaps heaps.private math.parser random assocs sequences sorting ; +heaps heaps.private math.parser random assocs sequences sorting +accessors ; IN: heaps.tests [ heap-pop ] must-fail @@ -47,7 +48,7 @@ IN: heaps.tests : test-entry-indices ( n -- ? ) random-alist [ heap-push-all ] keep - heap-data dup length swap [ entry-index ] map sequence= ; + data>> dup length swap [ entry-index ] map sequence= ; 14 [ [ t ] swap [ 2^ test-entry-indices ] curry unit-test @@ -63,9 +64,9 @@ IN: heaps.tests [ random-alist [ heap-push-all ] keep - dup heap-data clone swap + dup data>> clone swap ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times - heap-data + data>> [ [ entry-key ] map ] bi@ [ natural-sort ] bi@ ; diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 34a4dc0d49..783d662e43 100755 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -17,10 +17,10 @@ GENERIC: heap-size ( heap -- n ) ( class -- heap ) - >r V{ } clone r> construct-delegate ; inline + >r V{ } clone r> construct-boa ; inline TUPLE: entry value key heap index ; @@ -28,11 +28,11 @@ TUPLE: entry value key heap index ; PRIVATE> -TUPLE: min-heap ; +TUPLE: min-heap < heap ; : ( -- min-heap ) min-heap ; -TUPLE: max-heap ; +TUPLE: max-heap < heap ; : ( -- max-heap ) max-heap ; @@ -40,10 +40,10 @@ INSTANCE: min-heap priority-queue INSTANCE: max-heap priority-queue M: priority-queue heap-empty? ( heap -- ? ) - heap-data empty? ; + data>> empty? ; M: priority-queue heap-size ( heap -- n ) - heap-data length ; + data>> length ; > nth-unsafe ; inline : up-value ( n heap -- entry ) >r up r> data-nth ; inline @@ -67,24 +67,24 @@ M: priority-queue heap-size ( heap -- n ) : data-set-nth ( entry n heap -- ) >r [ swap set-entry-index ] 2keep r> - heap-data set-nth-unsafe ; + data>> set-nth-unsafe ; : data-push ( entry heap -- n ) dup heap-size [ - swap 2dup heap-data ensure 2drop data-set-nth + swap 2dup data>> ensure 2drop data-set-nth ] keep ; inline : data-pop ( heap -- entry ) - heap-data pop ; inline + data>> pop ; inline : data-pop* ( heap -- ) - heap-data pop* ; inline + data>> pop* ; inline : data-peek ( heap -- entry ) - heap-data peek ; inline + data>> peek ; inline : data-first ( heap -- entry ) - heap-data first ; inline + data>> first ; inline : data-exchange ( m n heap -- ) [ tuck data-nth >r data-nth r> ] 3keep diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 5ca9b1b2e7..c0de217bd1 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -3,14 +3,23 @@ USING: inference.dataflow inference.state arrays generic io io.streams.string kernel math namespaces parser prettyprint sequences strings vectors words quotations effects classes -continuations debugger assocs combinators compiler.errors ; +continuations debugger assocs combinators compiler.errors +generic.standard.engines.tuple accessors ; IN: inference.backend : recursive-label ( word -- label/f ) recursive-state get at ; -: inline? ( word -- ? ) - dup "method-generic" word-prop swap or "inline" word-prop ; +GENERIC: inline? ( word -- ? ) + +M: method-body inline? + "method-generic" word-prop inline? ; + +M: tuple-dispatch-engine-word inline? + "tuple-dispatch-generic" word-prop inline? ; + +M: word inline? + "inline" word-prop ; : local-recursive-state ( -- assoc ) recursive-state get dup keys @@ -23,18 +32,14 @@ IN: inference.backend : recursive-quotation? ( quot -- ? ) local-recursive-state [ first eq? ] with contains? ; -TUPLE: inference-error rstate type ; +TUPLE: inference-error error type rstate ; -M: inference-error compiler-error-type - inference-error-type ; +M: inference-error compiler-error-type type>> ; : (inference-error) ( ... class type -- * ) >r construct-boa r> - recursive-state get { - set-delegate - set-inference-error-type - set-inference-error-rstate - } \ inference-error construct throw ; inline + recursive-state get + \ inference-error construct-boa throw ; inline : inference-error ( ... class -- * ) +error+ (inference-error) ; inline diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 67b8616c61..038ab1d230 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -21,7 +21,7 @@ GENERIC: mynot ( x -- y ) M: f mynot drop t ; -M: general-t mynot drop f ; +M: object mynot drop f ; GENERIC: detect-f ( x -- y ) @@ -120,7 +120,7 @@ M: object xyz ; [ [ no-cond ] 1 [ 1array dup quotation? [ >quotation ] unless ] times - ] \ type inlined? + ] \ quotation? inlined? ] unit-test [ f ] [ [ length ] \ slot inlined? ] unit-test @@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ; \ >float inlined? ] unit-test +GENERIC: detect-float ( a -- b ) + +M: float detect-float ; + +[ t ] [ + [ { real float } declare + detect-float ] + \ detect-float inlined? +] unit-test + +[ t ] [ + [ { float real } declare + detect-float ] + \ detect-float inlined? +] unit-test + [ t ] [ [ 3 + = ] \ equal? inlined? ] unit-test @@ -297,3 +311,15 @@ cell-bits 32 = [ [ t ] [ [ { vector } declare nth-unsafe ] \ nth-unsafe inlined? ] unit-test + +[ t ] [ + [ + dup integer? [ + dup fixnum? [ + 1 + + ] [ + 2 + + ] if + ] when + ] \ + inlined? +] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 4aac98ce41..033d2cce7a 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -176,9 +176,18 @@ M: pair constraint-satisfied? : predicate-constraints ( class #call -- ) [ - 0 `input class, - general-t 0 `output class, - ] set-constraints ; + ! If word outputs true, input is an instance of class + [ + 0 `input class, + \ f class-not 0 `output class, + ] set-constraints + ] [ + ! If word outputs false, input is not an instance of class + [ + class-not 0 `input class, + \ f 0 `output class, + ] set-constraints + ] 2bi ; : compute-constraints ( #call -- ) dup node-param "constraints" word-prop [ @@ -209,7 +218,7 @@ M: #push infer-classes-before M: #if child-constraints [ - general-t 0 `input class, + \ f class-not 0 `input class, f 0 `input literal, ] make-constraints ; @@ -265,7 +274,7 @@ DEFER: (infer-classes) (merge-intervals) r> set-intervals ; : annotate-merge ( nodes #merge/#entry -- ) - 2dup merge-classes merge-intervals ; + [ merge-classes ] [ merge-intervals ] 2bi ; : merge-children ( node -- ) dup node-successor dup #merge? [ @@ -281,28 +290,31 @@ DEFER: (infer-classes) M: #label infer-classes-before ( #label -- ) #! First, infer types under the hypothesis which hold on #! entry to the recursive label. - dup 1array swap annotate-entry ; + [ 1array ] keep annotate-entry ; M: #label infer-classes-around ( #label -- ) #! Now merge the types at every recursion point with the #! entry types. - dup annotate-node - dup infer-classes-before - dup infer-children - dup collect-recursion over suffix - pick annotate-entry - node-child (infer-classes) ; + { + [ annotate-node ] + [ infer-classes-before ] + [ infer-children ] + [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ] + [ node-child (infer-classes) ] + } cleave ; M: object infer-classes-around - dup infer-classes-before - dup annotate-node - dup infer-children - merge-children ; + { + [ infer-classes-before ] + [ annotate-node ] + [ infer-children ] + [ merge-children ] + } cleave ; : (infer-classes) ( node -- ) [ - dup infer-classes-around - node-successor (infer-classes) + [ infer-classes-around ] + [ node-successor (infer-classes) ] bi ] when* ; : infer-classes-with ( node classes literals intervals -- ) diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 7fa2fbbcd3..a4b7ad1888 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -2,22 +2,20 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs kernel math namespaces parser sequences words vectors math.intervals effects classes -inference.state ; +inference.state accessors combinators ; IN: inference.dataflow ! Computed value : \ counter ; ! Literal value -TUPLE: value literal uid recursion ; +TUPLE: value < identity-tuple literal uid recursion ; : ( obj -- value ) recursive-state get value construct-boa ; M: value hashcode* nip value-uid ; -M: value equal? 2drop f ; - ! Result of curry TUPLE: curried obj quot ; @@ -30,24 +28,23 @@ C: composed UNION: special curried composed ; -TUPLE: node param +TUPLE: node < identity-tuple +param in-d out-d in-r out-r classes literals intervals history successor children ; -M: node equal? 2drop f ; - M: node hashcode* drop node hashcode* ; GENERIC: flatten-curry ( value -- ) M: curried flatten-curry - dup curried-obj flatten-curry - curried-quot flatten-curry ; + [ obj>> flatten-curry ] + [ quot>> flatten-curry ] bi ; M: composed flatten-curry - dup composed-quot1 flatten-curry - composed-quot2 flatten-curry ; + [ quot1>> flatten-curry ] + [ quot2>> flatten-curry ] bi ; M: object flatten-curry , ; @@ -60,31 +57,27 @@ M: object flatten-curry , ; meta-d get clone flatten-curries ; : modify-values ( node quot -- ) - [ swap [ node-in-d swap call ] keep set-node-in-d ] 2keep - [ swap [ node-in-r swap call ] keep set-node-in-r ] 2keep - [ swap [ node-out-d swap call ] keep set-node-out-d ] 2keep - swap [ node-out-r swap call ] keep set-node-out-r ; inline + { + [ change-in-d ] + [ change-in-r ] + [ change-out-d ] + [ change-out-r ] + } cleave drop ; inline : node-shuffle ( node -- shuffle ) - dup node-in-d swap node-out-d ; - -: make-node ( slots class -- node ) - >r node construct r> construct-delegate ; inline - -: empty-node ( class -- node ) - { } swap make-node ; inline + [ in-d>> ] [ out-d>> ] bi ; : param-node ( param class -- node ) - { set-node-param } swap make-node ; inline + construct-empty swap >>param ; inline : in-node ( seq class -- node ) - { set-node-in-d } swap make-node ; inline + construct-empty swap >>in-d ; inline : all-in-node ( class -- node ) flatten-meta-d swap in-node ; inline : out-node ( seq class -- node ) - { set-node-out-d } swap make-node ; inline + construct-empty swap >>out-d ; inline : all-out-node ( class -- node ) flatten-meta-d swap out-node ; inline @@ -97,81 +90,81 @@ M: object flatten-curry , ; : node-child node-children first ; -TUPLE: #label word loop? ; +TUPLE: #label < node word loop? ; : #label ( word label -- node ) - \ #label param-node [ set-#label-word ] keep ; + \ #label param-node swap >>word ; PREDICATE: #loop < #label #label-loop? ; -TUPLE: #entry ; +TUPLE: #entry < node ; : #entry ( -- node ) \ #entry all-out-node ; -TUPLE: #call ; +TUPLE: #call < node ; : #call ( word -- node ) \ #call param-node ; -TUPLE: #call-label ; +TUPLE: #call-label < node ; : #call-label ( label -- node ) \ #call-label param-node ; -TUPLE: #push ; +TUPLE: #push < node ; -: #push ( -- node ) \ #push empty-node ; +: #push ( -- node ) \ #push construct-empty ; -TUPLE: #shuffle ; +TUPLE: #shuffle < node ; -: #shuffle ( -- node ) \ #shuffle empty-node ; +: #shuffle ( -- node ) \ #shuffle construct-empty ; -TUPLE: #>r ; +TUPLE: #>r < node ; -: #>r ( -- node ) \ #>r empty-node ; +: #>r ( -- node ) \ #>r construct-empty ; -TUPLE: #r> ; +TUPLE: #r> < node ; -: #r> ( -- node ) \ #r> empty-node ; +: #r> ( -- node ) \ #r> construct-empty ; -TUPLE: #values ; +TUPLE: #values < node ; : #values ( -- node ) \ #values all-in-node ; -TUPLE: #return ; +TUPLE: #return < node ; : #return ( label -- node ) - \ #return all-in-node [ set-node-param ] keep ; + \ #return all-in-node swap >>param ; -TUPLE: #if ; +TUPLE: #branch < node ; + +TUPLE: #if < #branch ; : #if ( -- node ) peek-d 1array \ #if in-node ; -TUPLE: #dispatch ; +TUPLE: #dispatch < #branch ; : #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ; -TUPLE: #merge ; +TUPLE: #merge < node ; : #merge ( -- node ) \ #merge all-out-node ; -TUPLE: #terminate ; +TUPLE: #terminate < node ; -: #terminate ( -- node ) \ #terminate empty-node ; +: #terminate ( -- node ) \ #terminate construct-empty ; -TUPLE: #declare ; +TUPLE: #declare < node ; : #declare ( classes -- node ) \ #declare param-node ; -UNION: #branch #if #dispatch ; - : node-inputs ( d-count r-count node -- ) tuck - >r r-tail flatten-curries r> set-node-in-r - >r d-tail flatten-curries r> set-node-in-d ; + [ swap d-tail flatten-curries >>in-d drop ] + [ swap r-tail flatten-curries >>in-r drop ] 2bi* ; : node-outputs ( d-count r-count node -- ) tuck - >r r-tail flatten-curries r> set-node-out-r - >r d-tail flatten-curries r> set-node-out-d ; + [ swap d-tail flatten-curries >>out-d drop ] + [ swap r-tail flatten-curries >>out-r drop ] 2bi* ; : node, ( node -- ) dataflow-graph get [ @@ -181,17 +174,15 @@ UNION: #branch #if #dispatch ; ] if ; : node-values ( node -- values ) - dup node-in-d - over node-out-d - pick node-in-r - roll node-out-r 4array concat ; + { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave + 4array concat ; : last-node ( node -- last ) - dup node-successor [ last-node ] [ ] ?if ; + dup successor>> [ last-node ] [ ] ?if ; : penultimate-node ( node -- penultimate ) - dup node-successor dup [ - dup node-successor + dup successor>> dup [ + dup successor>> [ nip penultimate-node ] [ drop ] if ] [ 2drop f @@ -205,7 +196,7 @@ UNION: #branch #if #dispatch ; 2dup 2slip rot [ 2drop t ] [ - >r dup node-children swap node-successor suffix r> + >r [ children>> ] [ successor>> ] bi suffix r> [ node-exists? ] curry contains? ] if ] [ @@ -216,13 +207,13 @@ GENERIC: calls-label* ( label node -- ? ) M: node calls-label* 2drop f ; -M: #call-label calls-label* node-param eq? ; +M: #call-label calls-label* param>> eq? ; : calls-label? ( label node -- ? ) [ calls-label* ] with node-exists? ; : recursive-label? ( node -- ? ) - dup node-param swap calls-label? ; + [ param>> ] keep calls-label? ; SYMBOL: node-stack @@ -230,7 +221,7 @@ SYMBOL: node-stack : node> node-stack get pop ; : node@ node-stack get peek ; -: iterate-next ( -- node ) node@ node-successor ; +: iterate-next ( -- node ) node@ successor>> ; : iterate-nodes ( node quot -- ) over [ @@ -258,54 +249,55 @@ SYMBOL: node-stack ] iterate-nodes drop ] with-node-iterator ; inline -: change-children ( node quot -- ) +: map-children ( node quot -- ) over [ - >r dup node-children dup r> - [ map swap set-node-children ] curry - [ 2drop ] if + over children>> [ + [ map ] curry change-children drop + ] [ + 2drop + ] if ] [ 2drop ] if ; inline : (transform-nodes) ( prev node quot -- ) dup >r call dup [ - dup rot set-node-successor - dup node-successor r> (transform-nodes) + >>successor + successor>> dup successor>> + r> (transform-nodes) ] [ - r> drop f swap set-node-successor drop + r> 2drop f >>successor drop ] if ; inline : transform-nodes ( node quot -- new-node ) over [ - [ call dup dup node-successor ] keep (transform-nodes) + [ call dup dup successor>> ] keep (transform-nodes) ] [ drop ] if ; inline : node-literal? ( node value -- ? ) - dup value? >r swap node-literals key? r> or ; + dup value? >r swap literals>> key? r> or ; : node-literal ( node value -- obj ) dup value? - [ nip value-literal ] [ swap node-literals at ] if ; + [ nip value-literal ] [ swap literals>> at ] if ; : node-interval ( node value -- interval ) - swap node-intervals at ; + swap intervals>> at ; : node-class ( node value -- class ) - swap node-classes at object or ; + swap classes>> at object or ; : node-input-classes ( node -- seq ) - dup node-in-d [ node-class ] with map ; + dup in-d>> [ node-class ] with map ; : node-input-intervals ( node -- seq ) - dup node-in-d [ node-interval ] with map ; + dup in-d>> [ node-interval ] with map ; : node-class-first ( node -- class ) - dup node-in-d first node-class ; + dup in-d>> first node-class ; : active-children ( node -- seq ) - node-children - [ last-node ] map - [ #terminate? not ] subset ; + children>> [ last-node ] map [ #terminate? not ] subset ; DEFER: #tail? @@ -320,5 +312,5 @@ UNION: #tail #! We don't consider calls which do non-local exits to be #! tail calls, because this gives better error traces. node-stack get [ - node-successor dup #tail? swap #terminate? not and + successor>> [ #tail? ] [ #terminate? not ] bi and ] all? ; diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index 4d57ac5883..f565420cac 100644 --- a/core/inference/errors/errors.factor +++ b/core/inference/errors/errors.factor @@ -1,15 +1,15 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: inference.errors USING: inference.backend inference.dataflow kernel generic sequences prettyprint io words arrays inspector effects debugger -assocs ; +assocs accessors ; M: inference-error error. - dup inference-error-rstate + dup rstate>> keys [ dup value? [ value-literal ] when ] map dup empty? [ "Word: " write dup peek . ] unless - swap delegate error. "Nesting: " write . ; + swap error>> error. "Nesting: " write . ; M: inference-error error-help drop f ; diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 68e5920a3d..a837cfce5e 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -105,7 +105,7 @@ HELP: inference-error { $error-description "Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred." $nl - "This error always delegates to one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:" + "The " { $snippet "error" } " slot contains one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:" { $list { $link no-effect } { $link literal-expected } diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 84014512aa..f688f60e56 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -8,6 +8,9 @@ classes.predicate debugger threads.private io.streams.string io.timeouts io.thread sequences.private ; IN: inference.tests +[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test +[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test + { 0 2 } [ 2 "Hello" ] must-infer-as { 1 2 } [ dup ] must-infer-as @@ -542,3 +545,5 @@ ERROR: custom-error ; : missing->r-check >r ; [ [ missing->r-check ] infer ] must-fail + +{ 1 0 } [ [ ] map-children ] must-infer-as diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 79e41c8ae4..5092b86a4d 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -383,15 +383,9 @@ set-primitive-effect \ millis { } { integer } set-primitive-effect \ millis make-flushable -\ type { object } { fixnum } set-primitive-effect -\ type make-foldable - \ tag { object } { fixnum } set-primitive-effect \ tag make-foldable -\ class-hash { object } { fixnum } set-primitive-effect -\ class-hash make-foldable - \ cwd { } { string } set-primitive-effect \ cd { string } { } set-primitive-effect diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index cb8024d3c5..3fc8f37b4f 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,6 +1,7 @@ IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel -quotations inference accessors combinators words arrays ; +quotations inference accessors combinators words arrays +classes ; : compose-n-quot >quotation ; : compose-n compose-n-quot call ; @@ -56,3 +57,5 @@ C: color [ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test [ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test + +[ fixnum instance? ] must-infer diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 4cfe0432a5..d95ff9c3bc 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -3,7 +3,7 @@ USING: arrays kernel words sequences generic math namespaces quotations assocs combinators math.bitfields inference.backend inference.dataflow inference.state classes.tuple.private effects -inspector hashtables ; +inspector hashtables classes generic ; IN: inference.transforms : pop-literals ( n -- rstate seq ) @@ -43,6 +43,8 @@ IN: inference.transforms \ 2cleave [ 2cleave>quot ] 1 define-transform +\ 3cleave [ 3cleave>quot ] 1 define-transform + \ spread [ spread>quot ] 1 define-transform ! Bitfields @@ -96,3 +98,11 @@ M: duplicated-slots-error summary \ construct-empty 1 1 make-call-node ] if ] "infer" set-word-prop + +\ instance? [ + [ +inlined+ depends-on ] [ "predicate" word-prop ] bi +] 1 define-transform + +\ (call-next-method) [ + [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi +] 2 define-transform diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 342967acfc..1dd96a13fc 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -11,7 +11,9 @@ ARTICLE: "file-streams" "Reading and writing files" { $subsection with-file-reader } { $subsection with-file-writer } { $subsection with-file-appender } +{ $subsection set-file-contents } { $subsection file-contents } +{ $subsection set-file-lines } { $subsection file-lines } ; ARTICLE: "pathnames" "Pathname manipulation" @@ -27,11 +29,21 @@ ARTICLE: "pathnames" "Pathname manipulation" { $subsection pathname } { $subsection } ; +ARTICLE: "symbolic-links" "Symbolic links" +"Reading and creating links:" +{ $subsection read-link } +{ $subsection make-link } +"Copying links:" +{ $subsection copy-link } +"Not all operating systems support symbolic links." +{ $see-also link-info } ; + ARTICLE: "directories" "Directories" -"Current and home directories:" -{ $subsection cwd } -{ $subsection cd } +"Current directory:" +{ $subsection current-directory } +{ $subsection set-current-directory } { $subsection with-directory } +"Home directory:" { $subsection home } "Directory listing:" { $subsection directory } @@ -40,18 +52,26 @@ ARTICLE: "directories" "Directories" { $subsection make-directory } { $subsection make-directories } ; -! ARTICLE: "file-types" "File Types" - -! { $table { +directory+ "" } } - -! ; - -ARTICLE: "fs-meta" "File meta-data" +ARTICLE: "file-types" "File Types" +"Platform-independent types:" +{ $subsection +regular-file+ } +{ $subsection +directory+ } +"Platform-specific types:" +{ $subsection +character-device+ } +{ $subsection +block-device+ } +{ $subsection +fifo+ } +{ $subsection +symbolic-link+ } +{ $subsection +socket+ } +{ $subsection +unknown+ } ; +ARTICLE: "fs-meta" "File metadata" +"Querying file-system metadata:" { $subsection file-info } { $subsection link-info } { $subsection exists? } -{ $subsection directory? } ; +{ $subsection directory? } +"File types:" +{ $subsection "file-types" } ; ARTICLE: "delete-move-copy" "Deleting, moving, copying files" "Operations for deleting and copying files come in two forms:" @@ -120,39 +140,40 @@ HELP: file-name ! need a $class-description file-info HELP: file-info - - { $values { "path" "a pathname string" } - { "info" file-info } } - { $description "Queries the file system for meta data. " - "If path refers to a symbolic link, it is followed." - "If the file does not exist, an exception is thrown." } - - { $class-description "File meta data" } - - { $table - { "type" { "One of the following:" - { $list { $link +regular-file+ } - { $link +directory+ } - { $link +symbolic-link+ } } } } - - { "size" "Size of the file in bytes" } - { "modified" "Last modification timestamp." } } - - ; - -! need a see also to link-info +{ $values { "path" "a pathname string" } { "info" file-info } } +{ $description "Queries the file system for metadata. If " { $snippet "path" } " refers to a symbolic link, it is followed. See the article " { $link "file-types" } " for a list of metadata symbols." } +{ $errors "Throws an error if the file does not exist." } ; HELP: link-info - { $values { "path" "a pathname string" } - { "info" "a file-info tuple" } } - { $description "Queries the file system for meta data. " - "If path refers to a symbolic link, information about " - "the symbolic link itself is returned." - "If the file does not exist, an exception is thrown." } ; -! need a see also to file-info +{ $values { "path" "a pathname string" } { "info" "a file-info tuple" } } +{ $description "Queries the file system for metadata. If path refers to a symbolic link, information about the symbolic link itself is returned. If the file does not exist, an exception is thrown." } ; { file-info link-info } related-words +HELP: +regular-file+ +{ $description "A regular file. This type exists on all platforms. See " { $link "file-streams" } " for words operating on files." } ; + +HELP: +directory+ +{ $description "A directory. This type exists on all platforms. See " { $link "directories" } " for words operating on directories." } ; + +HELP: +symbolic-link+ +{ $description "A symbolic link file. This type is currently implemented on Unix platforms only. See " { $link "symbolic-links" } " for words operating on symbolic links." } ; + +HELP: +character-device+ +{ $description "A Unix character device file. This type exists on unix platforms only." } ; + +HELP: +block-device+ +{ $description "A Unix block device file. This type exists on unix platforms only." } ; + +HELP: +fifo+ +{ $description "A Unix fifo file. This type exists on unix platforms only." } ; + +HELP: +socket+ +{ $description "A Unix socket file. This type exists on unix platforms only." } ; + +HELP: +unknown+ +{ $description "A unknown file type." } ; + HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } } { "stream" "an input stream" } } @@ -184,37 +205,73 @@ HELP: with-file-appender { $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." } { $errors "Throws an error if the file cannot be opened for writing." } ; +HELP: set-file-lines +{ $values { "seq" "an array of strings" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } } +{ $description "Sets the contents of a file to the strings with the given encoding." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + HELP: file-lines { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } } { $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." } +{ $errors "Throws an error if the file cannot be opened for reading." } ; + +HELP: set-file-contents +{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } } +{ $description "Sets the contents of a file to a string with the given encoding." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: file-contents { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } } { $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." } -{ $errors "Throws an error if the file cannot be opened for writing." } ; +{ $errors "Throws an error if the file cannot be opened for reading." } ; + +{ set-file-lines file-lines set-file-contents file-contents } related-words HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; +{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } +{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ; HELP: cd { $values { "path" "a pathname string" } } { $description "Changes the current working directory of the Factor process." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; +{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } +{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ; -{ cd cwd with-directory } related-words +{ cd cwd current-directory set-current-directory with-directory } related-words + +HELP: current-directory +{ $description "A variable holding the current directory. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ; HELP: with-directory { $values { "path" "a pathname string" } { "quot" quotation } } -{ $description "Changes the current working directory for the duration of a quotation's execution." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; +{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ; HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Concatenates two pathnames." } ; +HELP: prepend-path +{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } +{ $description "Concatenates two pathnames." } ; + +{ append-path prepend-path } related-words + +HELP: absolute-path? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if a pathname is absolute. Examples of absolute pathnames are " { $snippet "/foo/bar" } " on Unix and " { $snippet "c:\\foo\\bar" } " on Windows." } ; + +HELP: windows-absolute-path? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if a pathname is absolute on Windows. Examples of absolute pathnames on Windows are " { $snippet "c:\\foo\\bar" } " and " { $snippet "\\\\?\\c:\\foo\\bar" } " for absolute Unicode pathnames." } ; + +HELP: root-directory? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if a pathname is a root directory. Examples of root directory pathnames are " { $snippet "/" } " on Unix and " { $snippet "c:\\" } " on Windows." } ; + +{ absolute-path? windows-absolute-path? root-directory? } related-words + HELP: exists? { $values { "path" "a pathname string" } { "?" "a boolean" } } { $description "Tests if the file named by " { $snippet "path" } " exists." } ; @@ -260,6 +317,20 @@ HELP: ( str -- pathname ) { $values { "str" "a pathname string" } { "pathname" pathname } } { $description "Creates a new " { $link pathname } "." } ; +HELP: make-link +{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } } +{ $description "Creates a symbolic link." } ; + +HELP: read-link +{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } } +{ $description "Reads the symbolic link and returns its target path." } ; + +HELP: copy-link +{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } } +{ $description "Copies a symbolic link without following the link." } ; + +{ make-link read-link copy-link } related-words + HELP: home { $values { "dir" string } } { $description "Outputs the user's home directory." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index b4a7d44433..5efbb9496d 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,7 @@ IN: io.files.tests -USING: tools.test io.files io threads kernel continuations -io.encodings.ascii io.files.unique sequences strings accessors -io.encodings.utf8 ; +USING: tools.test io.files io.files.private io threads kernel +continuations io.encodings.ascii io.files.unique sequences +strings accessors io.encodings.utf8 ; [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 720894d489..ed1b94e556 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -43,9 +43,9 @@ HOOK: (file-appender) io-backend ( path -- stream ) >r r> with-stream ; inline ! Pathnames -: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; +: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ; -: path-separator ( -- string ) windows? "\\" "/" ? ; +: path-separator ( -- string ) os windows? "\\" "/" ? ; : right-trim-separators ( str -- newstr ) [ path-separator? ] right-trim ; @@ -112,7 +112,7 @@ PRIVATE> { { [ dup empty? ] [ f ] } { [ dup "resource:" head? ] [ t ] } - { [ windows? ] [ windows-absolute-path? ] } + { [ os windows? ] [ windows-absolute-path? ] } { [ dup first path-separator? ] [ t ] } { [ t ] [ f ] } } cond nip ; @@ -153,19 +153,19 @@ HOOK: file-info io-backend ( path -- info ) ! Symlinks HOOK: link-info io-backend ( path -- info ) -HOOK: make-link io-backend ( path1 path2 -- ) +HOOK: make-link io-backend ( target symlink -- ) -HOOK: read-link io-backend ( path -- info ) +HOOK: read-link io-backend ( symlink -- path ) -: copy-link ( path1 path2 -- ) +: copy-link ( target symlink -- ) >r read-link r> make-link ; SYMBOL: +regular-file+ SYMBOL: +directory+ +SYMBOL: +symbolic-link+ SYMBOL: +character-device+ SYMBOL: +block-device+ SYMBOL: +fifo+ -SYMBOL: +symbolic-link+ SYMBOL: +socket+ SYMBOL: +unknown+ @@ -176,15 +176,18 @@ SYMBOL: +unknown+ : directory? ( path -- ? ) file-info file-info-type +directory+ = ; -! Current working directory + + +SYMBOL: current-directory + [ cwd current-directory set-global ] "io.files" add-init-hook : resource-path ( path -- newpath ) @@ -322,7 +325,7 @@ M: pathname <=> [ pathname-string ] compare ; ! Home directory : home ( -- dir ) { - { [ winnt? ] [ "USERPROFILE" os-env ] } - { [ wince? ] [ "" resource-path ] } - { [ unix? ] [ "HOME" os-env ] } + { [ os winnt? ] [ "USERPROFILE" os-env ] } + { [ os wince? ] [ "" resource-path ] } + { [ os unix? ] [ "HOME" os-env ] } } cond ; diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor index fa82c54163..6a956c6694 100755 --- a/core/io/streams/duplex/duplex-docs.factor +++ b/core/io/streams/duplex/duplex-docs.factor @@ -10,7 +10,7 @@ ARTICLE: "io.streams.duplex" "Duplex streams" ABOUT: "io.streams.duplex" HELP: duplex-stream -{ $class-description "A bidirectional stream delegating to a pair of streams, sending input to one delegate and output to another." } ; +{ $class-description "A bidirectional stream wrapping an input and output stream." } ; HELP: { $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } } diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor index e32c90a2fc..6b8953f86e 100755 --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -1,30 +1,59 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: io.streams.nested USING: arrays generic assocs kernel namespaces strings -quotations io continuations ; +quotations io continuations accessors sequences ; +IN: io.streams.nested -TUPLE: ignore-close-stream ; +TUPLE: filter-writer stream ; -: ignore-close-stream construct-delegate ; +M: filter-writer stream-format + stream>> stream-format ; + +M: filter-writer stream-write + stream>> stream-write ; + +M: filter-writer stream-write1 + stream>> stream-write1 ; + +M: filter-writer make-span-stream + stream>> make-span-stream ; + +M: filter-writer make-block-stream + stream>> make-block-stream ; + +M: filter-writer make-cell-stream + stream>> make-cell-stream ; + +M: filter-writer stream-flush + stream>> stream-flush ; + +M: filter-writer stream-nl + stream>> stream-nl ; + +M: filter-writer stream-write-table + stream>> stream-write-table ; + +M: filter-writer dispose + stream>> dispose ; + +TUPLE: ignore-close-stream < filter-writer ; M: ignore-close-stream dispose drop ; -TUPLE: style-stream style ; +C: ignore-close-stream -: do-nested-style ( style stream -- style delegate ) - [ style-stream-style swap union ] keep - delegate ; inline +TUPLE: style-stream < filter-writer style ; -: ( style delegate -- stream ) - { set-style-stream-style set-delegate } - style-stream construct ; +: do-nested-style ( style style-stream -- style stream ) + [ style>> swap union ] [ stream>> ] bi ; inline + +C: style-stream M: style-stream stream-format do-nested-style stream-format ; M: style-stream stream-write - dup style-stream-style swap delegate stream-format ; + [ style>> ] [ stream>> ] bi stream-format ; M: style-stream stream-write1 >r 1string r> stream-write ; @@ -33,15 +62,13 @@ M: style-stream make-span-stream do-nested-style make-span-stream ; M: style-stream make-block-stream - [ do-nested-style make-block-stream ] keep - style-stream-style swap ; + [ do-nested-style make-block-stream ] [ style>> ] bi + ; M: style-stream make-cell-stream - [ do-nested-style make-cell-stream ] keep - style-stream-style swap ; + [ do-nested-style make-cell-stream ] [ style>> ] bi + ; -TUPLE: block-stream ; - -: block-stream construct-delegate ; - -M: block-stream dispose drop ; +M: style-stream stream-write-table + [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri* + stream-write-table ; diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor index 4898a58fb1..47bff681cd 100644 --- a/core/io/streams/plain/plain.factor +++ b/core/io/streams/plain/plain.factor @@ -12,7 +12,7 @@ M: plain-writer stream-format nip stream-write ; M: plain-writer make-span-stream - ; + swap ; M: plain-writer make-block-stream nip ; diff --git a/core/io/streams/string/string-docs.factor b/core/io/streams/string/string-docs.factor index 91ac244608..5b09baa56d 100644 --- a/core/io/streams/string/string-docs.factor +++ b/core/io/streams/string/string-docs.factor @@ -13,7 +13,7 @@ ABOUT: "io.streams.string" HELP: { $values { "stream" "an output stream" } } -{ $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ; +{ $description "Creates an output stream that collects text into a string buffer. The contents of the buffer can be obtained by executing " { $link >string } "." } ; HELP: with-string-writer { $values { "quot" quotation } { "str" string } } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index b1120de8e6..4578e2a93f 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -217,9 +217,7 @@ $nl { $example "\\ f class ." "word" } "On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of." { $example "t \\ t eq? ." "t" } -"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." -$nl -"A tuple cannot delegate to " { $link f } " at all, since a delegate of " { $link f } " actually denotes that no delegate is set. See " { $link set-delegate } "." ; +"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; ARTICLE: "conditionals" "Conditionals and logic" "The basic conditionals:" @@ -250,8 +248,9 @@ $nl { $subsection eq? } "Value comparison:" { $subsection = } -"Generic words for custom value comparison methods:" +"Custom value comparison methods:" { $subsection equal? } +{ $subsection identity-tuple } "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":" { $subsection <=> } { $subsection compare } @@ -275,9 +274,11 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "apply-combinators" } { $subsection "slip-keep-combinators" } { $subsection "conditionals" } +{ $subsection "compositional-combinators" } { $subsection "combinators" } "Advanced topics:" { $subsection "implementing-combinators" } +{ $subsection "errors" } { $subsection "continuations" } ; ABOUT: "dataflow" @@ -340,6 +341,9 @@ HELP: set-callstack ( cs -- ) HELP: clear { $description "Clears the data stack." } ; +HELP: build +{ $description "The current build number. Factor increments this number whenever a new boot image is created." } ; + HELP: hashcode* { $values { "depth" integer } { "obj" object } { "code" fixnum } } { $contract "Outputs the hashcode of an object. The hashcode operation must satisfy the following properties:" @@ -377,10 +381,13 @@ HELP: equal? } $nl "If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word." -} +} ; + +HELP: identity-tuple +{ $class-description "A class defining an " { $link equal? } " method which always returns f." } { $examples - "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:" - { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" } + "To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:" + { $code "TUPLE: foo < identity-tuple ;" } "By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:" { $unchecked-example "T{ foo } dup = ." "t" } { $unchecked-example "T{ foo } dup clone = ." "f" } @@ -389,7 +396,7 @@ HELP: equal? HELP: <=> { $values { "obj1" object } { "obj2" object } { "n" real } } { $contract - "Compares two objects using an intrinsic partial order, for example, the natural order for real numbers and lexicographic order for strings." + "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings." $nl "The output value is one of the following:" { $list @@ -413,12 +420,6 @@ HELP: clone { $values { "obj" object } { "cloned" "a new object" } } { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ; -HELP: type ( object -- n ) -{ $values { "object" object } { "n" "a type number" } } -{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ; - -{ type tag type>class } related-words - HELP: ? ( ? true false -- true/false ) { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; @@ -671,6 +672,11 @@ HELP: bi@ "[ p ] bi@" ">r p r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] bi@" + "[ p ] [ p ] bi*" + } } ; HELP: 2bi@ @@ -682,6 +688,11 @@ HELP: 2bi@ "[ p ] 2bi@" ">r >r p r> r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] 2bi@" + "[ p ] [ p ] 2bi*" + } } ; HELP: tri@ @@ -693,6 +704,11 @@ HELP: tri@ "[ p ] tri@" ">r >r p r> p r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] tri@" + "[ p ] [ p ] [ p ] tri*" + } } ; HELP: if ( cond true false -- ) @@ -791,19 +807,6 @@ HELP: null "The canonical empty class with no instances." } ; -HELP: general-t -{ $class-description - "The class of all objects not equal to " { $link f } "." -} -{ $examples - "Here is an implementation of " { $link if } " using generic words:" - { $code - "GENERIC# my-if 2 ( ? true false -- )" - "M: f my-if 2nip call ;" - "M: general-t my-if drop nip call ;" - } -} ; - HELP: most { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } } { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ; @@ -846,11 +849,15 @@ HELP: with { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" } } ; -HELP: compose -{ $values { "quot1" callable } { "quot2" callable } { "curry" curry } } +HELP: compose ( quot1 quot2 -- compose ) +{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." } { $notes - "The following two lines are equivalent:" + "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:" + { $code + "[ 3 >r ] [ r> . ] compose" + } + "Except for this restriction, the following two lines are equivalent:" { $code "compose call" "append call" @@ -862,7 +869,15 @@ HELP: 3compose { $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." } { $notes - "The following two lines are equivalent:" + "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:" + { $code + "[ >r ] swap [ r> ] 3compose" + } + "The correct way to achieve the effect of the above is the following:" + { $code + "[ dip ] curry" + } + "Excepting the retain stack restriction, the following two lines are equivalent:" { $code "3compose call" "3append call" diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index ab42a1b903..2b1dd3cf9c 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel.private ; +USING: kernel.private slots.private classes.tuple.private ; IN: kernel ! Stack stuff @@ -99,14 +99,14 @@ DEFER: if ! Appliers : bi@ ( x y quot -- ) - tuck 2slip call ; inline + dup bi* ; inline : tri@ ( x y z quot -- ) - tuck >r bi@ r> call ; inline + dup dup tri* ; inline ! Double appliers : 2bi@ ( w x y z quot -- ) - dup -roll 3slip call ; inline + dup 2bi* ; inline : while ( pred body tail -- ) >r >r dup slip r> r> roll @@ -114,12 +114,6 @@ DEFER: if [ 2nip call ] if ; inline ! Object protocol -GENERIC: delegate ( obj -- delegate ) - -M: object delegate drop f ; - -GENERIC: set-delegate ( delegate tuple -- ) - GENERIC: hashcode* ( depth obj -- code ) M: object hashcode* 2drop 0 ; @@ -130,6 +124,10 @@ GENERIC: equal? ( obj1 obj2 -- ? ) M: object equal? 2drop f ; +TUPLE: identity-tuple ; + +M: identity-tuple equal? 2drop f ; + : = ( obj1 obj2 -- ? ) 2dup eq? [ 2drop t ] [ equal? ] if ; inline @@ -142,18 +140,11 @@ M: object clone ; M: callstack clone (clone) ; ! Tuple construction -GENERIC# get-slots 1 ( tuple slots -- ... ) +: construct-empty ( class -- tuple ) + tuple-layout ; -GENERIC# set-slots 1 ( ... tuple slots -- ) - -GENERIC: construct-empty ( class -- tuple ) - -GENERIC: construct ( ... slots class -- tuple ) inline - -GENERIC: construct-boa ( ... class -- tuple ) - -: construct-delegate ( delegate class -- tuple ) - >r { set-delegate } r> construct ; inline +: construct-boa ( ... class -- tuple ) + tuple-layout ; ! Quotation building : 2curry ( obj1 obj2 quot -- curry ) @@ -194,8 +185,23 @@ GENERIC: construct-boa ( ... class -- tuple ) + +! Deprecated +M: object delegate drop f ; + +GENERIC# get-slots 1 ( tuple slots -- ... ) + +GENERIC# set-slots 1 ( ... tuple slots -- ) + +: construct ( ... slots class -- tuple ) + construct-empty [ swap set-slots ] keep ; inline + +: construct-delegate ( delegate class -- tuple ) + >r { set-delegate } r> construct ; inline diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor index d4188dd3b6..a54df30c50 100755 --- a/core/layouts/layouts-docs.factor +++ b/core/layouts/layouts-docs.factor @@ -1,6 +1,6 @@ USING: generic help.markup help.syntax kernel math memory namespaces sequences kernel.private classes -sequences.private ; +classes.builtin sequences.private ; IN: layouts HELP: tag-bits @@ -14,7 +14,7 @@ HELP: tag-mask { $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ; HELP: num-types -{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ; +{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ; HELP: tag-number { $values { "class" class } { "n" "an integer or " { $link f } } } @@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits ARTICLE: "layouts-types" "Type numbers" "Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:" -{ $subsection type } +{ $subsection hi-tag } "Built-in type numbers can be converted to classes, and vice versa:" { $subsection type>class } { $subsection type-number } diff --git a/core/listener/listener.factor b/core/listener/listener.factor index bf262b77a2..ddb29bb768 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -3,7 +3,7 @@ USING: arrays hashtables io kernel math math.parser memory namespaces parser sequences strings io.styles io.streams.duplex vectors words generic system combinators -continuations debugger definitions compiler.units ; +continuations debugger definitions compiler.units accessors ; IN: listener SYMBOL: quit-flag @@ -19,7 +19,7 @@ GENERIC: stream-read-quot ( stream -- quot/f ) : read-quot-step ( lines -- quot/f ) [ parse-lines-interactive ] [ - dup delegate unexpected-eof? + dup error>> unexpected-eof? [ 2drop f ] [ rethrow ] if ] recover ; diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 6ec1c5790f..5533c00090 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -83,6 +83,29 @@ HELP: >= { $values { "x" real } { "y" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ; +HELP: before? +{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." } +{ $notes "Implemented using " { $link <=> } "." } ; + +HELP: after? +{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." } +{ $notes "Implemented using " { $link <=> } "." } ; + +HELP: before=? +{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." } +{ $notes "Implemented using " { $link <=> } "." } ; + +HELP: after=? +{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." } +{ $notes "Implemented using " { $link <=> } "." } ; + +{ before? after? before=? after=? } related-words + + HELP: + { $values { "x" number } { "y" number } { "z" number } } { $description diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 8808b30c59..0c46e307df 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,5 +1,6 @@ USING: generic kernel kernel.private math memory prettyprint -sequences tools.test words namespaces layouts classes ; +sequences tools.test words namespaces layouts classes +classes.builtin ; IN: memory.tests TUPLE: testing x y z ; diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor index 725a757e61..dc4315fb39 100755 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -7,9 +7,6 @@ $nl "A mirror provides such a view of a tuple:" { $subsection mirror } { $subsection } -"An enum provides such a view of a sequence:" -{ $subsection enum } -{ $subsection } "Utility word used by developer tools which inspect objects:" { $subsection make-mirror } { $see-also "slots" } ; @@ -44,11 +41,6 @@ HELP: >mirror< { $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } } { $description "Pushes the object being viewed in the mirror together with its slots." } ; -HELP: enum -{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence." -$nl -"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ; - HELP: make-mirror { $values { "obj" object } { "assoc" assoc } } { $description "Creates an assoc which reflects the internal structure of the object." } ; diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index fde8728858..a13e1331fa 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -48,27 +48,6 @@ M: mirror assoc-size mirror-slots length ; INSTANCE: mirror assoc -TUPLE: enum seq ; - -C: enum - -M: enum at* - enum-seq 2dup bounds-check? - [ nth t ] [ 2drop f f ] if ; - -M: enum set-at enum-seq set-nth ; - -M: enum delete-at enum-seq delete-nth ; - -M: enum >alist ( enum -- alist ) - enum-seq dup length swap 2array flip ; - -M: enum assoc-size enum-seq length ; - -M: enum clear-assoc enum-seq delete-all ; - -INSTANCE: enum assoc - : sort-assoc ( assoc -- alist ) >alist [ dup first unparse-short swap ] { } map>assoc diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 1703bea5d4..e6b7533756 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -51,7 +51,7 @@ GENERIC: optimize-node* ( node -- node/t changed? ) DEFER: optimize-nodes : optimize-children ( node -- ) - [ optimize-nodes ] change-children ; + [ optimize-nodes ] map-children ; : optimize-node ( node -- node ) dup [ diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index c108e3b1a7..11228c879a 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -154,7 +154,7 @@ SYMBOL: potential-loops ] [ node-class { { [ dup null class< ] [ drop f f ] } - { [ dup general-t class< ] [ drop t t ] } + { [ dup \ f class-not class< ] [ drop t t ] } { [ dup \ f class< ] [ drop f t ] } { [ t ] [ drop f f ] } } cond diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index df5c1e0aa4..54fca38ee2 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -100,7 +100,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ; dup [ dup [ dead-literals get swap remove-all ] modify-values dup kill-node* dup t eq? [ - drop dup [ kill-nodes ] change-children + drop dup [ kill-nodes ] map-children ] [ nip kill-node ] if diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 1f3df92421..9d41d6eae1 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -70,12 +70,25 @@ DEFER: (flat-length) ] if ; ! Partial dispatch of math-generic words +: normalize-math-class ( class -- class' ) + { + fixnum bignum integer + ratio rational + float real + complex number + object + } [ class< ] with find nip ; + : math-both-known? ( word left right -- ? ) math-class-max swap specific-method ; : inline-math-method ( #call word -- node ) - over node-input-classes first2 3dup math-both-known? - [ math-method f splice-quot ] [ 2drop 2drop t ] if ; + over node-input-classes + [ first normalize-math-class ] + [ second normalize-math-class ] bi + 3dup math-both-known? + [ math-method f splice-quot ] + [ 2drop 2drop t ] if ; : inline-method ( #call -- node ) dup node-param { diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 108c715ef0..2bce2dc94c 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -75,7 +75,7 @@ sequences.private combinators ; dup node-in-d second dup value? [ swap [ value-literal 0 `input literal, - general-t 0 `output class, + \ f class-not 0 `output class, ] set-constraints ] [ 2drop @@ -87,29 +87,6 @@ sequences.private combinators ; { { @ @ } [ 2drop t ] } } define-identities -! type applied to an object of a known type can be folded -: known-type? ( node -- ? ) - node-class-first class-types length 1 number= ; - -: fold-known-type ( node -- node ) - dup node-class-first class-types inline-literals ; - -\ type [ - { [ dup known-type? ] [ fold-known-type ] } -] define-optimizers - -! if the result of type is n, then the object has type n -{ tag type } [ - [ - num-types get swap [ - [ - [ type>class object or 0 `input class, ] keep - 0 `output literal, - ] set-constraints - ] curry each - ] "constraints" set-word-prop -] each - ! Specializers { 1+ 1- sq neg recip sgn } [ { number } "specializer" set-word-prop diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index abe48ec272..4ec4bfeb36 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -269,7 +269,7 @@ generic.standard system ; : comparison-constraints ( node true false -- ) >r >r dup node set intervals dup [ 2dup - r> general-t (comparison-constraints) + r> \ f class-not (comparison-constraints) r> \ f (comparison-constraints) ] [ r> r> 2drop 2drop diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index aa081e8e2c..6c6adfa3e6 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -140,12 +140,6 @@ GENERIC: void-generic ( obj -- * ) [ breakage ] must-fail ! regression -: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline -: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline -: test-2 ( -- ) 5 test-1 ; - -[ f ] [ f test-2 ] unit-test - : branch-fold-regression-0 ( m -- n ) t [ ] [ 1+ branch-fold-regression-0 ] if ; inline diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index cbdb1b9ec4..d115d0a1c6 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math namespaces sequences vectors words strings layouts combinators -sequences.private classes generic.standard assocs ; +sequences.private classes generic.standard +generic.standard.engines assocs ; IN: optimizer.specializers : (make-specializer) ( class picker -- quot ) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index cc4e2c0a42..61fd9f7f30 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -445,18 +445,10 @@ HELP: eval { $description "Parses Factor source code from a string, and calls the resulting quotation." } { $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ; -HELP: outside-usages -{ $values { "seq" "a sequence of definitions" } { "usages" "an association list mapping definitions to sequences of definitions" } } -{ $description "Outputs an association list mapping elements of " { $snippet "seq" } " to lists of usages which exclude the definitions in " { $snippet "seq" } " themselves." } ; - HELP: filter-moved { $values { "assoc" "an assoc where the keys are definitions" } { "newassoc" "an assoc where the keys are definitions" } } { $description "Removes all definitions from the assoc which are no longer present in the current " { $link file } "." } ; -HELP: smudged-usage -{ $values { "usages" "a sequence of definitions which reference removed definitions" } { "referenced" "a sequence of definitions removed from this source file which are still referenced elsewhere" } { "removed" "a sequence of definitions removed from this source file" } } -{ $description "Collects information about changed word definitioins after parsing." } ; - HELP: forget-smudged { $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 6bd4abb7e1..ab193e1c02 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words io.streams.string namespaces classes effects source-files assocs sequences strings io.files definitions continuations sorting classes.tuple compiler.units debugger vocabs -vocabs.loader ; +vocabs.loader accessors ; IN: parser.tests [ @@ -297,12 +297,12 @@ IN: parser.tests [ "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" "removing-the-predicate" parse-stream - ] [ [ redefine-error? ] is? ] must-fail-with + ] [ error>> error>> redefine-error? ] must-fail-with [ "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;" "redefining-a-class-1" parse-stream - ] [ [ redefine-error? ] is? ] must-fail-with + ] [ error>> error>> redefine-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test" @@ -312,7 +312,7 @@ IN: parser.tests [ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" "redefining-a-class-3" parse-stream drop - ] [ [ redefine-error? ] is? ] must-fail-with + ] [ error>> error>> redefine-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-fwd-test ;" @@ -322,7 +322,7 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ [ no-word-error? ] is? ] must-fail-with + ] [ error>> error>> no-word-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" @@ -332,12 +332,12 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ [ no-word-error? ] is? ] must-fail-with + ] [ error>> error>> no-word-error? ] must-fail-with [ "IN: parser.tests : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop - ] [ [ redefine-error? ] is? ] must-fail-with + ] [ error>> error>> redefine-error? ] must-fail-with [ ] [ "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval @@ -348,47 +348,6 @@ IN: parser.tests ] must-fail ] with-file-vocabs -[ - << file get parsed >> file set - - : ~a ; - - DEFER: ~b - - "IN: parser.tests : ~b ~a ;" - "smudgy" parse-stream drop - - : ~c ; - : ~d ; - - { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set - - { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set - - [ V{ ~b } { ~a } { ~a ~c } ] [ - smudged-usage - natural-sort - ] unit-test -] with-scope - -[ - << file get parsed >> file set - - GENERIC: ~e - - : ~f ~e ; - - : ~g ; - - { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set - - { H{ { ~g ~g } } H{ } } new-definitions set - - [ V{ } { } { ~e ~f } ] - [ smudged-usage natural-sort ] - unit-test -] with-scope - [ ] [ "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 58c68a3614..7db7e46b3a 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -157,23 +157,33 @@ name>char-hook global [ [ swap tail-slice (parse-string) ] "" make swap ] change-lexer-column ; -TUPLE: parse-error file line col text ; +TUPLE: parse-error file line column line-text error ; : ( msg -- error ) - file get - lexer get [ line>> ] [ column>> ] [ line-text>> ] tri - parse-error construct-boa - [ set-delegate ] keep ; + \ parse-error construct-empty + file get >>file + lexer get line>> >>line + lexer get column>> >>column + lexer get line-text>> >>line-text + swap >>error ; : parse-dump ( error -- ) - dup parse-error-file file. - dup parse-error-line number>string print - dup parse-error-text dup string? [ print ] [ drop ] if - parse-error-col 0 or CHAR: \s write + { + [ file>> file. ] + [ line>> number>string print ] + [ line-text>> dup string? [ print ] [ drop ] if ] + [ column>> 0 or CHAR: \s write ] + } cleave "^" print ; M: parse-error error. - dup parse-dump delegate error. ; + [ parse-dump ] [ error>> error. ] bi ; + +M: parse-error summary + error>> summary ; + +M: parse-error compute-restarts + error>> compute-restarts ; SYMBOL: use SYMBOL: in @@ -365,7 +375,17 @@ ERROR: bad-number ; : (:) CREATE-WORD parse-definition ; -: (M:) CREATE-METHOD parse-definition ; +SYMBOL: current-class +SYMBOL: current-generic + +: (M:) + CREATE-METHOD + [ + [ "method-class" word-prop current-class set ] + [ "method-generic" word-prop current-generic set ] + [ ] tri + parse-definition + ] with-scope ; : scan-object ( -- object ) scan-word dup parsing? @@ -399,6 +419,7 @@ SYMBOL: bootstrap-syntax SYMBOL: interactive-vocabs { + "accessors" "arrays" "assocs" "combinators" @@ -454,60 +475,44 @@ SYMBOL: interactive-vocabs "Loading " write . flush ] if ; -: smudged-usage-warning ( usages removed -- ) - parser-notes? [ - "Warning: the following definitions were removed from sources," print - "but are still referenced from other definitions:" print - nl - dup sorted-definitions. - nl - "The following definitions need to be updated:" print - nl - over sorted-definitions. - nl - ] when 2drop ; - -: filter-moved ( assoc -- newassoc ) - [ +: filter-moved ( assoc1 assoc2 -- seq ) + diff [ drop where dup [ first ] when file get source-file-path = - ] assoc-subset ; + ] assoc-subset keys ; -: removed-definitions ( -- definitions ) +: removed-definitions ( -- assoc1 assoc2 ) new-definitions old-definitions - [ get first2 union ] bi@ diff ; + [ get first2 union ] bi@ ; -: smudged-usage ( -- usages referenced removed ) - removed-definitions filter-moved keys [ - outside-usages - [ - empty? [ drop f ] [ - { - { [ dup pathname? ] [ f ] } - { [ dup method-body? ] [ f ] } - { [ t ] [ t ] } - } cond nip - ] if - ] assoc-subset - dup values concat prune swap keys - ] keep ; +: removed-classes ( -- assoc1 assoc2 ) + new-definitions old-definitions + [ get second ] bi@ ; + +: forget-removed-definitions ( -- ) + removed-definitions filter-moved forget-all ; + +: reset-removed-classes ( -- ) + removed-classes + filter-moved [ class? ] subset [ reset-class ] each ; : fix-class-words ( -- ) #! If a class word had a compound definition which was #! removed, it must go back to being a symbol. - new-definitions get first2 diff - [ nip dup reset-generic define-symbol ] assoc-each ; + new-definitions get first2 + filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ; : forget-smudged ( -- ) - smudged-usage forget-all - over empty? [ 2dup smudged-usage-warning ] unless 2drop + forget-removed-definitions + reset-removed-classes fix-class-words ; : finish-parsing ( lines quot -- ) file get - [ record-form ] keep - [ record-definitions ] keep - record-checksum ; + [ record-form ] + [ record-definitions ] + [ record-checksum ] + tri ; : parse-stream ( stream name -- quot ) [ diff --git a/core/prettyprint/config/config-docs.factor b/core/prettyprint/config/config-docs.factor index f197ac7966..1a2fd69949 100644 --- a/core/prettyprint/config/config-docs.factor +++ b/core/prettyprint/config/config-docs.factor @@ -4,12 +4,6 @@ IN: prettyprint.config ABOUT: "prettyprint-variables" -HELP: indent -{ $var-description "The prettyprinter's current indent level." } ; - -HELP: pprinter-stack -{ $var-description "A stack of " { $link block } " objects currently being constructed by the prettyprinter." } ; - HELP: tab-size { $var-description "Prettyprinter tab size. Indent nesting is always a multiple of the tab size." } ; diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor index 7ea0f5c412..2b294115be 100755 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -48,7 +48,7 @@ ARTICLE: "prettyprint-limitations" "Prettyprinter limitations" "On a final note, the " { $link short. } " and " { $link pprint-short } " words restrict the length and nesting of printed sequences, their output will very likely not be valid syntax. They are only intended for interactive use." ; ARTICLE: "prettyprint-section-protocol" "Prettyprinter section protocol" -"Prettyprinter sections must delegate to an instance of " { $link section } ", and they must also obey a protocol." +"Prettyprinter sections must subclass " { $link section } ", and they must also obey a protocol." $nl "Layout queries:" { $subsection section-fits? } @@ -60,8 +60,8 @@ $nl { $subsection short-section } { $subsection long-section } "Utilities to use when implementing sections:" -{ $subsection
} -{ $subsection delegate>block } +{ $subsection construct-section } +{ $subsection construct-block } { $subsection add-section } ; ARTICLE: "prettyprint-sections" "Prettyprinter sections" diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 27b63ec26f..e94670992c 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -57,8 +57,6 @@ unit-test [ ] [ \ integer see ] unit-test -[ ] [ \ general-t see ] unit-test - [ ] [ \ generic see ] unit-test [ ] [ \ duplex-stream see ] unit-test @@ -335,3 +333,6 @@ PREDICATE: predicate-see-test < integer even? ; [ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [ [ \ predicate-see-test see ] with-string-writer ] unit-test + +[ ] [ \ compose see ] unit-test +[ ] [ \ curry see ] unit-test diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index d294f95be6..03d3e456ca 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -5,9 +5,9 @@ USING: alien arrays generic generic.standard assocs io kernel math namespaces sequences strings io.styles io.streams.string vectors words prettyprint.backend prettyprint.sections prettyprint.config sorting splitting math.parser vocabs -definitions effects classes.tuple io.files classes continuations -hashtables classes.mixin classes.union classes.predicate -combinators quotations ; +definitions effects classes.builtin classes.tuple io.files +classes continuations hashtables classes.mixin classes.union +classes.predicate classes.singleton combinators quotations ; : make-pprint ( obj quot -- block in use ) [ @@ -254,6 +254,9 @@ M: predicate-class see-class* "predicate-definition" word-prop pprint-elements pprint-; block> block> ; +M: singleton-class see-class* ( class -- ) + \ SINGLETON: pprint-word pprint-word ; + M: tuple-class see-class* +HELP: construct-section { $values { "style" hashtable } { "length" integer } { "section" section } } { $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ; -HELP: change-indent -{ $values { "section" section } { "n" integer } } -{ $description "If the section requests indentation, adds " { $snippet "n" } " to the indent level, otherwise does nothing." } ; - HELP: ( -- pprinter ) 0 1 f 0 pprinter construct-boa ; + : record-vocab ( word -- ) word-vocabulary [ dup pprinter-use get set-at ] when* ; ! Utility words : line-limit? ( -- ? ) - line-limit get dup [ line-count get <= ] when ; + line-limit get dup [ pprinter get line-count>> <= ] when ; -: do-indent ( -- ) indent get CHAR: \s write ; +: do-indent ( -- ) pprinter get indent>> CHAR: \s write ; : fresh-line ( n -- ) - dup last-newline get = [ + dup pprinter get last-newline>> = [ drop ] [ - last-newline set - line-limit? [ "..." write end-printing get continue ] when - line-count inc + pprinter get (>>last-newline) + line-limit? [ + "..." write pprinter get end-printing>> continue + ] when + pprinter get [ 1+ ] change-line-count drop nl do-indent ] if ; : text-fits? ( len -- ? ) margin get dup zero? - [ 2drop t ] [ >r indent get + r> <= ] if ; + [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ; ! break only if position margin 2 / > SYMBOL: soft @@ -70,17 +71,17 @@ start end start-group? end-group? style overhang ; -:
( style length -- section ) - position [ dup rot + dup ] change 0 { - set-section-style - set-section-start - set-section-end - set-section-overhang - } section construct ; +: construct-section ( length class -- section ) + construct-empty + position get >>start + swap position [ + ] change + position get >>end + 0 >>overhang ; inline M: section section-fits? ( section -- ? ) - dup section-end last-newline get - - swap section-overhang + text-fits? ; + [ end>> pprinter get last-newline>> - ] + [ overhang>> ] bi + + text-fits? ; M: section indent-section? drop f ; @@ -90,18 +91,20 @@ M: section newline-after? drop f ; M: object short-section? section-fits? ; -: change-indent ( section n -- ) - swap indent-section? [ indent +@ ] [ drop ] if ; +: indent+ ( section n -- ) + swap indent-section? [ + pprinter get [ + ] change-indent drop + ] [ drop ] if ; -: ( section -- ) tab-size get neg change-indent ; +: indent> ( section -- ) tab-size get neg indent+ ; : > fresh-line ; : fresh-line> ( section -- ) - dup newline-after? [ section-end fresh-line ] [ drop ] if ; + dup newline-after? [ end>> fresh-line ] [ drop ] if ; : ( section -- ) dup indent> fresh-line> ; -: with-style* ( style quot -- ) - swap stdio [ ] change - call stdio [ delegate ] change ; inline - : pprint-section ( section -- ) dup short-section? [ - dup section-style [ short-section ] with-style* + dup section-style [ short-section ] with-style ] [ - dup + [ ] + tri ] if ; ! Break section -TUPLE: line-break type ; +TUPLE: line-break < section type ; : ( type -- section ) - H{ } 0
- { set-line-break-type set-delegate } - \ line-break construct ; + 0 \ line-break construct-section + swap >>type ; M: line-break short-section drop ; M: line-break long-section drop ; ! Block sections -TUPLE: block sections ; +TUPLE: block < section sections ; + +: construct-block ( style class -- block ) + 0 swap construct-section + V{ } clone >>sections + swap >>style ; inline : ( style -- block ) - 0
V{ } clone - { set-delegate set-block-sections } block construct ; - -: delegate>block ( obj -- ) H{ } swap set-delegate ; + block construct-block ; : pprinter-block ( -- block ) pprinter-stack get peek ; : add-section ( section -- ) - pprinter-block block-sections push ; + pprinter-block sections>> push ; : last-section ( -- section ) - pprinter-block block-sections + pprinter-block sections>> [ line-break? not ] find-last nip ; : start-group ( -- ) - t last-section set-section-start-group? ; + last-section t >>start-group? drop ; : end-group ( -- ) - t last-section set-section-end-group? ; + last-section t >>end-group? drop ; : advance ( section -- ) - dup section-start last-newline get = not - swap short-section? and - [ bl ] when ; + [ start>> pprinter get last-newline>> = not ] + [ short-section? ] bi + and [ bl ] when ; : line-break ( type -- ) [ add-section ] when* ; M: block section-fits? ( section -- ? ) - line-limit? [ drop t ] [ delegate section-fits? ] if ; + line-limit? [ drop t ] [ call-next-method ] if ; : pprint-sections ( block advancer -- ) - swap block-sections [ line-break? not ] subset + swap sections>> [ line-break? not ] subset unclip pprint-section [ dup rot call pprint-section ] with each ; inline @@ -179,28 +180,29 @@ M: block short-section ( block -- ) [ advance ] pprint-sections ; : do-break ( break -- ) - dup line-break-type hard eq? - over section-end last-newline get - margin get 2/ > or - [ > hard eq? ] + [ end>> pprinter get last-newline>> - margin get 2/ > ] tri + or [ > empty? ; : if-nonempty ( block quot -- ) >r dup empty-block? [ drop ] r> if ; inline : ( ( ( ( ( string style -- text ) - over length 1+
- { set-text-string set-delegate } - \ text construct ; + over length 1+ \ text construct-section + swap >>style + swap >>string ; M: text short-section text-string write ; @@ -211,18 +213,18 @@ M: text long-section short-section ; : text ( string -- ) H{ } styled-text ; ! Inset section -TUPLE: inset narrow? ; +TUPLE: inset < block narrow? ; : ( narrow? -- block ) - 2 H{ } - { set-inset-narrow? set-section-overhang set-delegate } - inset construct ; + H{ } inset construct-block + 2 >>overhang + swap >>narrow? ; M: inset long-section - dup inset-narrow? [ + dup narrow?>> [ [ ( ( -- block ) - H{ } flow construct-delegate ; + H{ } flow construct-block ; M: flow short-section? ( section -- ? ) #! If we can make room for this entire block by inserting #! a newline, do it; otherwise, don't bother, print it as #! a short section - dup section-fits? - over section-end rot section-start - text-fits? not or ; + [ section-fits? ] + [ [ end>> ] [ start>> ] bi - text-fits? not ] bi + or ; : ( ( -- block ) - H{ } colon construct-delegate ; + H{ } colon construct-block ; M: colon long-section short-section ; @@ -261,28 +264,23 @@ M: colon unindent-first-line? drop t ; : (>end drop ; : block> ( -- ) pprinter-stack get pop - [ dup save-end-position add-section ] if-nonempty ; - -: with-section-state ( quot -- ) - [ - 0 indent set - 0 last-newline set - 1 line-count set - call - ] with-scope ; inline + [ [ save-end-position ] [ add-section ] bi ] if-nonempty ; : do-pprint ( block -- ) - [ + pprinter [ [ - dup section-style [ - [ end-printing set dup short-section ] callcc0 - ] with-nesting drop + dup style>> [ + [ + >r pprinter get (>>end-printing) r> + short-section + ] curry callcc0 + ] with-nesting ] if-nonempty - ] with-section-state ; + ] with-variable ; ! Long section layout algorithm : chop-break ( seq -- seq ) @@ -298,9 +296,9 @@ M: f section-start-group? drop t ; M: f section-end-group? drop f ; : split-before ( section -- ) - dup section-start-group? prev get section-end-group? and - swap flow? prev get flow? not and - or split-groups ; + [ section-start-group? prev get section-end-group? and ] + [ flow? prev get flow? not and ] + bi or split-groups ; : split-after ( section -- ) section-end-group? split-groups ; @@ -315,19 +313,19 @@ M: f section-end-group? drop f ; ] { } make { t } split [ empty? not ] subset ; : break-group? ( seq -- ? ) - dup first section-fits? swap peek section-fits? not and ; + [ first section-fits? ] [ peek section-fits? not ] bi and ; : ?break-group ( seq -- ) dup break-group? [ first > chop-break group-flow [ dup ?break-group [ dup line-break? [ do-break ] [ - dup advance pprint-section + [ advance ] [ pprint-section ] bi ] if ] each ] each diff --git a/core/refs/refs-tests.factor b/core/refs/refs-tests.factor new file mode 100644 index 0000000000..1d921854e9 --- /dev/null +++ b/core/refs/refs-tests.factor @@ -0,0 +1,22 @@ +USING: refs tools.test kernel ; + +[ 3 ] [ + H{ { "a" 3 } } "a" get-ref +] unit-test + +[ 4 ] [ + 4 H{ { "a" 3 } } clone "a" + [ set-ref ] keep + get-ref +] unit-test + +[ "a" ] [ + H{ { "a" 3 } } "a" get-ref +] unit-test + +[ H{ { "b" 3 } } ] [ + "b" H{ { "a" 3 } } clone [ + "a" + set-ref + ] keep +] unit-test diff --git a/core/refs/refs.factor b/core/refs/refs.factor index c52c5daf9e..81a2338b8f 100644 --- a/core/refs/refs.factor +++ b/core/refs/refs.factor @@ -5,21 +5,18 @@ IN: refs TUPLE: ref assoc key ; -: ( assoc key class -- tuple ) - >r ref construct-boa r> construct-delegate ; inline - -: >ref< ( ref -- key assoc ) [ key>> ] [ assoc>> ] bi ; +: >ref< [ key>> ] [ assoc>> ] bi ; inline : delete-ref ( ref -- ) >ref< delete-at ; GENERIC: get-ref ( ref -- obj ) GENERIC: set-ref ( obj ref -- ) -TUPLE: key-ref ; -: ( assoc key -- ref ) key-ref ; -M: key-ref get-ref ref-key ; +TUPLE: key-ref < ref ; +C: key-ref ( assoc key -- ref ) +M: key-ref get-ref key>> ; M: key-ref set-ref >ref< rename-at ; -TUPLE: value-ref ; -: ( assoc key -- ref ) value-ref ; +TUPLE: value-ref < ref ; +C: value-ref ( assoc key -- ref ) M: value-ref get-ref >ref< at ; M: value-ref set-ref >ref< set-at ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index ca46066861..01a1cb9b6a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -416,6 +416,9 @@ PRIVATE> swap >r [ push ] curry compose r> while ] keep { } like ; inline +: follow ( obj quot -- seq ) + >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline + : index ( obj seq -- n ) [ = ] with find drop ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 2b0d721f3e..29facb31f2 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax generic kernel.private parser words kernel quotations namespaces sequences words arrays -effects generic.standard classes.tuple slots.private classes -strings math ; +effects generic.standard classes.tuple classes.builtin +slots.private classes strings math ; IN: slots ARTICLE: "accessors" "Slot accessors" diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 8dea367b6b..b385fbf369 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.crc32 vocabs hashtables -graphs compiler.units io.encodings.utf8 ; +graphs compiler.units io.encodings.utf8 accessors ; IN: source-files SYMBOL: source-files @@ -56,10 +56,14 @@ uses definitions ; M: pathname where pathname-string 1 2array ; : forget-source ( path -- ) - dup source-file - dup unxref-source - source-file-definitions [ keys forget-all ] each - source-files get delete-at ; + [ + source-file + [ unxref-source ] + [ definitions>> [ keys forget-all ] each ] + bi + ] + [ source-files get delete-at ] + bi ; M: pathname forget* pathname-string forget-source ; @@ -78,9 +82,3 @@ SYMBOL: file source-file-definitions old-definitions set [ ] [ file get rollback-source-file ] cleanup ] with-scope ; inline - -: outside-usages ( seq -- usages ) - dup [ - over usage - [ dup pathname? not swap where and ] subset seq-diff - ] curry { } map>assoc ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index bd349953df..61e77ae9a5 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,6 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math -arrays io.files vocabs.loader io sequences assocs ; +generic.standard arrays io.files vocabs.loader io sequences +assocs ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" @@ -243,7 +244,7 @@ HELP: flushable HELP: t { $syntax "t" } { $values { "t" "the canonical truth value" } } -{ $description "The canonical instance of " { $link general-t } ". It is just a symbol." } ; +{ $class-description "The canonical truth value, which is an instance of itself." } ; HELP: f { $syntax "f" } @@ -332,8 +333,8 @@ HELP: C{ { $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ; HELP: T{ -{ $syntax "T{ class delegate slots... }" } -{ $values { "class" "a tuple class word" } { "delegate" "a delegate" } { "slots" "list of objects" } } +{ $syntax "T{ class slots... }" } +{ $values { "class" "a tuple class word" } { "slots" "list of objects" } } { $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "." $nl "The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ; @@ -564,9 +565,17 @@ HELP: TUPLE: HELP: ERROR: { $syntax "ERROR: class slots... ;" } { $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } } -{ $description "Defines a new tuple class. Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ; - -{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words +{ $description "Defines a new tuple class whose class word throws a new instance of the error." } +{ $notes + "The following two snippets are equivalent:" + { $code + "ERROR: invalid-values x y ;" + "" + "TUPLE: invalid-values x y ;" + ": invalid-values ( x y -- * )" + " \\ invalid-values construct-boa throw ;" + } +} ; HELP: C: { $syntax "C: constructor class" } @@ -633,4 +642,18 @@ HELP: >> { $syntax ">>" } { $description "Marks the end of a parse time code block." } ; +HELP: call-next-method +{ $description "Calls the next applicable method. Only valid inside a method definition. The values at the top of the stack are passed on to the next method, and they must be compatible with that method's class specializer." } +{ $notes "This is syntax sugar around " { $link (call-next-method) } ". The following two lines are equivalent:" + { $code + "M: my-class my-generic ... call-next-method ... ;" + "M: my-class my-generic ... \\ my-class \\ my-generic (call-next-method) ... ;" + } +"In most cases, this word should be called with the original input values on the stack. Calling it with other values is usually a sign of poor design." } +{ $errors + "Throws a " { $link no-next-method } " error if this is the least specific method, and throws an " { $link inconsistent-next-method } " error if the values at the top of the stack are not compatible with the current method's specializer." +} ; + +{ POSTPONE: call-next-method (call-next-method) next-method } related-words + { POSTPONE: << POSTPONE: >> } related-words diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 19fdf0e45f..005672c1c6 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -5,8 +5,8 @@ byte-vectors definitions generic hashtables kernel math namespaces parser sequences strings sbufs vectors words quotations io assocs splitting classes.tuple generic.standard generic.math classes io.files vocabs float-arrays float-vectors -classes.union classes.mixin classes.predicate compiler.units -combinators debugger ; +classes.union classes.mixin classes.predicate classes.singleton +compiler.units combinators debugger ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -55,7 +55,7 @@ IN: bootstrap.syntax "BIN:" [ 2 parse-base ] define-syntax "f" [ f parsed ] define-syntax - "t" "syntax" lookup define-symbol + "t" "syntax" lookup define-singleton-class "CHAR:" [ scan { @@ -154,6 +154,11 @@ IN: bootstrap.syntax parse-definition define-predicate-class ] define-syntax + "SINGLETON:" [ + scan create-class-in + dup save-location define-singleton-class + ] define-syntax + "TUPLE:" [ parse-tuple-definition define-tuple-class ] define-syntax @@ -185,4 +190,10 @@ IN: bootstrap.syntax [ \ >> parse-until >quotation ] with-compilation-unit call ] define-syntax + + "call-next-method" [ + current-class get literalize parsed + current-generic get literalize parsed + \ (call-next-method) parsed + ] define-syntax ] with-compilation-unit diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index 7e7a5ff215..df112bd786 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -1,20 +1,12 @@ USING: generic help.markup help.syntax kernel math memory -namespaces sequences kernel.private strings ; +namespaces sequences kernel.private strings classes.singleton ; IN: system -ARTICLE: "os" "System interface" -"Operating system detection:" -{ $subsection os } -{ $subsection unix? } -{ $subsection macosx? } -{ $subsection solaris? } -{ $subsection windows? } -{ $subsection winnt? } -{ $subsection win32? } -{ $subsection win64? } -{ $subsection wince? } -"Processor detection:" -{ $subsection cpu } +ABOUT: "system" + +ARTICLE: "system" "System interface" +{ $subsection "cpu" } +{ $subsection "os" } "Reading environment variables:" { $subsection os-env } { $subsection os-envs } @@ -27,63 +19,51 @@ ARTICLE: "os" "System interface" { $subsection exit } { $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; -ABOUT: "os" +ARTICLE: "cpu" "Processor Detection" +"Processor detection:" +{ $subsection cpu } +"Supported processors:" +{ $subsection x86.32 } +{ $subsection x86.64 } +{ $subsection ppc } +{ $subsection arm } +"Processor families:" +{ $subsection x86 } ; + +ARTICLE: "os" "Operating System Detection" +"Operating system detection:" +{ $subsection os } +"Supported operating systems:" +{ $subsection freebsd } +{ $subsection linux } +{ $subsection macosx } +{ $subsection openbsd } +{ $subsection netbsd } +{ $subsection solaris } +{ $subsection wince } +{ $subsection winnt } +"Operating system families:" +{ $subsection bsd } +{ $subsection unix } +{ $subsection windows } ; + HELP: cpu -{ $values { "cpu" string } } +{ $values { "class" singleton-class } } { $description - "Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:" - { $code "x86.32" "x86.64" "ppc" "arm" } + "Outputs a singleton class with the name of the current CPU architecture." } ; HELP: os -{ $values { "os" string } } +{ $values { "class" singleton-class } } { $description - "Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:" - { $code - "freebsd" - "linux" - "macosx" - "openbsd" - "netbsd" - "solaris" - "wince" - "winnt" - } + "Outputs a singleton class with the name of the current operating system family." } ; HELP: embedded? { $values { "?" "a boolean" } } { $description "Tests if this Factor instance is embedded in another application." } ; -HELP: windows? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on Windows." } ; - -HELP: winnt? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on Windows XP or Vista." } ; - -HELP: wince? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on Windows CE." } ; - -HELP: macosx? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on Mac OS X." } ; - -HELP: linux? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on Linux." } ; - -HELP: solaris? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on Solaris." } ; - -HELP: bsd? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on FreeBSD/OpenBSD/NetBSD." } ; - HELP: exit ( n -- ) { $values { "n" "an integer exit code" } } { $description "Exits the Factor process." } ; @@ -120,14 +100,6 @@ HELP: set-os-envs { os-env os-envs set-os-envs } related-words -HELP: win32? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on 32-bit Windows." } ; - -HELP: win64? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on 64-bit Windows." } ; - HELP: image { $values { "path" "a pathname string" } } { $description "Outputs the pathname of the currently running Factor image." } ; @@ -135,7 +107,3 @@ HELP: image HELP: vm { $values { "path" "a pathname string" } } { $description "Outputs the pathname of the currently running Factor VM." } ; - -HELP: unix? -{ $values { "?" "a boolean" } } -{ $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ; diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index 4b074ed7aa..14e34ccb17 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -1,11 +1,11 @@ USING: math tools.test system prettyprint namespaces kernel ; IN: system.tests -wince? [ +os wince? [ [ ] [ os-envs . ] unit-test ] unless -unix? [ +os unix? [ [ ] [ os-envs "envs" set ] unit-test [ ] [ { { "A" "B" } } set-os-envs ] unit-test [ "B" ] [ "A" os-env ] unit-test diff --git a/core/system/system.factor b/core/system/system.factor index 87bbcfdc3f..98dc605acc 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -2,49 +2,70 @@ ! See http://factorcode.org/license.txt for BSD license. IN: system USING: kernel kernel.private sequences math namespaces -splitting assocs system.private layouts ; +init splitting assocs system.private layouts words ; -: cpu ( -- cpu ) 8 getenv ; foldable +SINGLETON: x86.32 +SINGLETON: x86.64 +SINGLETON: arm +SINGLETON: ppc -: os ( -- os ) 9 getenv ; foldable +UNION: x86 x86.32 x86.64 ; + +: cpu ( -- class ) \ cpu get ; + +SINGLETON: winnt +SINGLETON: wince + +UNION: windows winnt wince ; + +SINGLETON: freebsd +SINGLETON: netbsd +SINGLETON: openbsd +SINGLETON: solaris +SINGLETON: macosx +SINGLETON: linux + +UNION: bsd freebsd netbsd openbsd macosx ; + +UNION: unix bsd solaris linux ; + +: os ( -- class ) \ os get ; + +cpu ( str -- class ) + H{ + { "x86.32" x86.32 } + { "x86.64" x86.64 } + { "arm" arm } + { "ppc" ppc } + } at ; + +: string>os ( str -- class ) + H{ + { "winnt" winnt } + { "wince" wince } + { "freebsd" freebsd } + { "netbsd" netbsd } + { "openbsd" openbsd } + { "solaris" solaris } + { "macosx" macosx } + { "linux" linux } + } at ; + +PRIVATE> + +[ + 8 getenv string>cpu \ cpu set-global + 9 getenv string>os \ os set-global +] "system" add-init-hook : image ( -- path ) 13 getenv ; : vm ( -- path ) 14 getenv ; -: wince? ( -- ? ) - os "wince" = ; foldable - -: winnt? ( -- ? ) - os "winnt" = ; foldable - -: windows? ( -- ? ) - wince? winnt? or ; foldable - -: win32? ( -- ? ) - winnt? cell 4 = and ; foldable - -: win64? ( -- ? ) - winnt? cell 8 = and ; foldable - -: macosx? ( -- ? ) os "macosx" = ; foldable - : embedded? ( -- ? ) 15 getenv ; -: unix? ( -- ? ) - os { - "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris" - } member? ; - -: bsd? ( -- ? ) - os { "freebsd" "openbsd" "netbsd" "macosx" } member? ; - -: linux? ( -- ? ) - os "linux" = ; - -: solaris? ( -- ? ) - os "solaris" = ; - : os-envs ( -- assoc ) (os-envs) [ "=" split1 ] H{ } map>assoc ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 4b978932bc..1191594fe5 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -3,7 +3,7 @@ IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs classes.tuple definitions -debugger compiler.units tools.vocabs ; +debugger compiler.units tools.vocabs accessors ; ! This vocab should not exist, but just in case... [ ] [ @@ -68,7 +68,7 @@ IN: vocabs.loader.tests "resource:core/vocabs/loader/test/a/a.factor" parse-stream -] [ [ no-word-error? ] is? ] must-fail-with +] [ error>> error>> no-word-error? ] must-fail-with 0 "count-me" set-global diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index a6a5a014a7..8ef5f6f508 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -6,13 +6,11 @@ IN: vocabs SYMBOL: dictionary -TUPLE: vocab +TUPLE: vocab < identity-tuple name words main help source-loaded? docs-loaded? ; -M: vocab equal? 2drop f ; - : ( name -- vocab ) H{ } clone { set-vocab-name set-vocab-words } @@ -92,10 +90,6 @@ TUPLE: vocab-link name ; : ( name -- vocab-link ) vocab-link construct-boa ; -M: vocab-link equal? - over vocab-link? - [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ; - M: vocab-link hashcode* vocab-link-name hashcode* ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index eb1bd0908a..a715aab64f 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -324,11 +324,7 @@ HELP: constructor-word { $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." } { $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "" } } ; -HELP: forget-word -{ $values { "word" word } } -{ $description "Removes a word from its vocabulary. User code should call " { $link forget } " instead, since it also does the right thing when forgetting class words." } ; - -{ POSTPONE: FORGET: forget forget-word forget-vocab } related-words +{ POSTPONE: FORGET: forget forget* forget-vocab } related-words HELP: target-word { $values { "word" word } { "target" word } } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index cef6b19943..694e54cf96 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,7 +1,7 @@ USING: arrays generic assocs kernel math namespaces sequences tools.test words definitions parser quotations vocabs continuations classes.tuple compiler.units -io.streams.string ; +io.streams.string accessors ; IN: words.tests [ 4 ] [ @@ -147,7 +147,7 @@ SYMBOL: quot-uses-b ] when* [ "IN: words.tests : undef-test ; << undef-test >>" eval ] -[ [ undefined? ] is? ] must-fail-with +[ error>> undefined? ] must-fail-with [ ] [ "IN: words.tests GENERIC: symbol-generic" eval diff --git a/core/words/words.factor b/core/words/words.factor index 5c0d84d4cc..2510c50347 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -63,10 +63,11 @@ SYMBOL: bootstrapping? : bootstrap-word ( word -- target ) [ target-word ] [ ] if-bootstrapping ; -: crossref? ( word -- ? ) +GENERIC: crossref? ( word -- ? ) + +M: word crossref? { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method-generic" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; @@ -120,8 +121,28 @@ SYMBOL: +called+ compiled-usage [ nip +inlined+ eq? ] assoc-subset update ] with each keys ; -M: word redefined* ( word -- ) - { "inferred-effect" "no-effect" } reset-props ; + + +: redefined ( word -- ) + H{ } clone visited [ (redefined) ] with-variable ; SYMBOL: changed-words @@ -172,7 +193,7 @@ GENERIC: subwords ( word -- seq ) M: word subwords drop f ; : reset-generic ( word -- ) - dup subwords [ forget ] each + dup subwords forget-all dup reset-word { "methods" "combination" "default-method" } reset-props ; @@ -211,9 +232,7 @@ M: word where "loc" word-prop ; M: word set-where swap "loc" set-word-prop ; -GENERIC: forget-word ( word -- ) - -: (forget-word) ( word -- ) +M: word forget* dup "forgotten" word-prop [ dup delete-xref dup delete-compiled-xref @@ -221,10 +240,6 @@ GENERIC: forget-word ( word -- ) dup t "forgotten" set-word-prop ] unless drop ; -M: word forget-word (forget-word) ; - -M: word forget* forget-word ; - M: word hashcode* nip 1 slot { fixnum } declare ; diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 065f7dd5c4..a38107fbab 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -5,8 +5,8 @@ IN: bootstrap.io "bootstrap.compiler" vocab [ "io." { { [ "io-backend" get ] [ "io-backend" get ] } - { [ unix? ] [ "unix" ] } - { [ winnt? ] [ "windows.nt" ] } - { [ wince? ] [ "windows.ce" ] } + { [ os unix? ] [ "unix" ] } + { [ os winnt? ] [ "windows.nt" ] } + { [ os wince? ] [ "windows.ce" ] } } cond append require ] when diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor index daf35b9c03..fa0c54d0c6 100755 --- a/extra/bootstrap/random/random.factor +++ b/extra/bootstrap/random/random.factor @@ -5,8 +5,8 @@ namespaces random ; "random.mersenne-twister" require { - { [ windows? ] [ "random.windows" require ] } - { [ unix? ] [ "random.unix" require ] } + { [ os windows? ] [ "random.windows" require ] } + { [ os unix? ] [ "random.unix" require ] } } cond ! [ [ 32 random-bits ] with-secure-random random-generator set-global ] diff --git a/extra/bootstrap/ui/ui.factor b/extra/bootstrap/ui/ui.factor index f8db831dbc..5aa7683efc 100644 --- a/extra/bootstrap/ui/ui.factor +++ b/extra/bootstrap/ui/ui.factor @@ -4,9 +4,9 @@ vocabs vocabs.loader ; "bootstrap.compiler" vocab [ "ui-backend" get [ { - { [ macosx? ] [ "cocoa" ] } - { [ windows? ] [ "windows" ] } - { [ unix? ] [ "x11" ] } + { [ os macosx? ] [ "cocoa" ] } + { [ os windows? ] [ "windows" ] } + { [ os unix? ] [ "x11" ] } } cond ] unless* "ui." prepend require diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 2982f675b4..c555233410 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -245,4 +245,4 @@ USE: bootstrap.image.download ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MAIN: build-loop \ No newline at end of file +MAIN: build-loop diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index c319ade93b..200c85c929 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -7,16 +7,14 @@ ! - most of the matrix stuff ! - most of the query functions - USING: alien alien.syntax combinators system ; - IN: cairo.ffi << "cairo" { - { [ win32? ] [ "libcairo-2.dll" ] } - ! { [ macosx? ] [ "libcairo.dylib" ] } - { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } - { [ unix? ] [ "libcairo.so.2" ] } + { [ os winnt? ] [ "libcairo-2.dll" ] } + ! { [ os macosx? ] [ "libcairo.dylib" ] } + { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } + { [ os unix? ] [ "libcairo.so.2" ] } } cond "cdecl" add-library >> LIBRARY: cairo diff --git a/extra/calendar/backend/backend.factor b/extra/calendar/backend/backend.factor index 01c36c65ae..56ccf9e6cc 100644 --- a/extra/calendar/backend/backend.factor +++ b/extra/calendar/backend/backend.factor @@ -1,5 +1,4 @@ -USING: kernel ; +USING: kernel system ; IN: calendar.backend -SYMBOL: calendar-backend -HOOK: gmt-offset calendar-backend ( -- hours minutes seconds ) +HOOK: gmt-offset os ( -- hours minutes seconds ) diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 6c29c0d1ac..8dcb4af7f1 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -377,6 +377,6 @@ M: timestamp sleep-until timestamp>millis sleep-until ; M: duration sleep from-now sleep-until ; { - { [ unix? ] [ "calendar.unix" ] } - { [ windows? ] [ "calendar.windows" ] } + { [ os unix? ] [ "calendar.unix" ] } + { [ os windows? ] [ "calendar.windows" ] } } cond require diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor index 2877fa07b5..6383d4ec42 100644 --- a/extra/calendar/unix/unix.factor +++ b/extra/calendar/unix/unix.factor @@ -1,17 +1,12 @@ USING: alien alien.c-types arrays calendar.backend -kernel structs math unix.time namespaces ; - +kernel structs math unix.time namespaces system ; IN: calendar.unix -TUPLE: unix-calendar ; - -T{ unix-calendar } calendar-backend set-global - : get-time ( -- alien ) f time localtime ; : timezone-name ( -- string ) get-time tm-zone ; -M: unix-calendar gmt-offset ( -- hours minutes seconds ) +M: unix gmt-offset ( -- hours minutes seconds ) get-time tm-gmtoff 3600 /mod 60 /mod ; diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 8548e4ee52..2986422155 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -1,12 +1,8 @@ -USING: calendar.backend namespaces alien.c-types +USING: calendar.backend namespaces alien.c-types system windows windows.kernel32 kernel math combinators ; IN: calendar.windows -TUPLE: windows-calendar ; - -T{ windows-calendar } calendar-backend set-global - -M: windows-calendar gmt-offset ( -- hours minutes seconds ) +M: windows gmt-offset ( -- hours minutes seconds ) "TIME_ZONE_INFORMATION" dup GetTimeZoneInformation { { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] } diff --git a/extra/classes/singleton/singleton-docs.factor b/extra/classes/singleton/singleton-docs.factor deleted file mode 100644 index 95b5b6af18..0000000000 --- a/extra/classes/singleton/singleton-docs.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: help.markup help.syntax kernel words ; -IN: classes.singleton - -HELP: SINGLETON: -{ $syntax "SINGLETON: class" -} { $values - { "class" "a new singleton to define" } -} { $description - "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton." -} { $examples - { $example "USING: singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } -} { $see-also - POSTPONE: PREDICATE: -} ; diff --git a/extra/classes/singleton/singleton.factor b/extra/classes/singleton/singleton.factor deleted file mode 100755 index 61a519679c..0000000000 --- a/extra/classes/singleton/singleton.factor +++ /dev/null @@ -1,22 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: classes.predicate kernel namespaces parser quotations -sequences words prettyprint prettyprint.backend prettyprint.sections -compiler.units classes ; -IN: classes.singleton - -PREDICATE: singleton < predicate-class - [ "predicate-definition" word-prop ] - [ [ eq? ] curry ] bi sequence= ; - -: define-singleton ( token -- ) - create-class-in - dup save-location - \ singleton - over [ eq? ] curry define-predicate-class ; - -: SINGLETON: - scan define-singleton ; parsing - -M: singleton see-class* ( class -- ) - ] } - { [ windows? ] [ "127.0.0.1" 1238 ] } - } cond ; - -[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test - -[ ] [ test-node dup 1array swap (start-node) ] unit-test - -[ ] [ yield ] unit-test - -[ ] [ - [ - receive first2 >r 3 + r> send - "thread-a" unregister-process - ] "Thread A" spawn - "thread-a" swap register-process -] unit-test - -[ 8 ] [ - 5 self 2array - "thread-a" test-node send - - receive -] unit-test - -[ ] [ test-node stop-node ] unit-test +IN: concurrency.distributed.tests +USING: tools.test concurrency.distributed kernel io.files +arrays io.sockets system combinators threads math sequences +concurrency.messaging continuations ; + +: test-node + { + { [ os unix? ] [ "distributed-concurrency-test" temp-file ] } + { [ os windows? ] [ "127.0.0.1" 1238 ] } + } cond ; + +[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test + +[ ] [ test-node dup 1array swap (start-node) ] unit-test + +[ ] [ yield ] unit-test + +[ ] [ + [ + receive first2 >r 3 + r> send + "thread-a" unregister-process + ] "Thread A" spawn + "thread-a" swap register-process +] unit-test + +[ 8 ] [ + 5 self 2array + "thread-a" test-node send + + receive +] unit-test + +[ ] [ test-node stop-node ] unit-test diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 6365b91517..d0da724cc6 100755 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -5,8 +5,9 @@ sequences sequences.lib assocs system sorting math.parser ; IN: contributors : changelog ( -- authors ) - image parent-directory cd - "git-log --pretty=format:%an" lines ; + image parent-directory [ + "git-log --pretty=format:%an" lines + ] with-directory ; : patch-counts ( authors -- assoc ) dup prune diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor index 55da97202f..4a070190e3 100644 --- a/extra/crypto/barrett/barrett.factor +++ b/extra/crypto/barrett/barrett.factor @@ -4,5 +4,11 @@ IN: crypto.barrett : barrett-mu ( n size -- mu ) #! Calculates Barrett's reduction parameter mu #! size = word size in bits (8, 16, 32, 64, ...) - over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ; + ! over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ; + [ + [ log2 1+ ] [ / 2 * ] bi* + ] [ + 2^ rot ^ swap /i + ] 2bi ; + diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor index b53ecaac3c..559c7934d0 100644 --- a/extra/crypto/common/common-docs.factor +++ b/extra/crypto/common/common-docs.factor @@ -2,23 +2,6 @@ USING: help.markup help.syntax kernel math sequences quotations math.private ; IN: crypto.common -HELP: >32-bit -{ $values { "x" integer } { "y" integer } } -{ $description "Used to implement 32-bit integer overflow." } ; - -HELP: >64-bit -{ $values { "x" integer } { "y" integer } } -{ $description "Used to implement 64-bit integer overflow." } ; - -HELP: bitroll -{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } -{ $description "Roll n by s bits to the left, wrapping around after w bits." } -{ $examples - { $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } - { $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } -} ; - - HELP: hex-string { $values { "seq" "a sequence" } { "str" "a string" } } { $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." } diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index 3ac551d114..a714727ad9 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -1,11 +1,8 @@ USING: arrays kernel io io.binary sbufs splitting strings sequences -namespaces math math.parser parser hints ; +namespaces math math.parser parser hints math.bitfields.lib ; IN: crypto.common -: >32-bit ( x -- y ) HEX: ffffffff bitand ; inline -: >64-bit ( x -- y ) HEX: ffffffffffffffff bitand ; inline - -: w+ ( int int -- int ) + >32-bit ; inline +: w+ ( int int -- int ) + 32 bits ; inline : (nth-int) ( string n -- int ) 2 shift dup 4 + rot ; inline @@ -39,26 +36,9 @@ SYMBOL: big-endian? 3 shift 8 rot [ >be ] [ >le ] if % ] "" make 64 group ; -: shift-mod ( n s w -- n ) - >r shift r> 2^ 1- bitand ; inline - : update-old-new ( old new -- ) [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline -: bitroll ( x s w -- y ) - [ 1 - bitand ] keep - over 0 < [ [ + ] keep ] when - [ shift-mod ] 3keep - [ - ] keep shift-mod bitor ; inline - -: bitroll-32 ( n s -- n' ) 32 bitroll ; - -HINTS: bitroll-32 bignum fixnum ; - -: bitroll-64 ( n s -- n' ) 64 bitroll ; - -HINTS: bitroll-64 bignum fixnum ; - : hex-string ( seq -- str ) [ [ >hex 2 48 pad-left % ] each ] "" make ; @@ -70,9 +50,8 @@ HINTS: bitroll-64 bignum fixnum ; : 2seq>seq ( seq1 seq2 -- seq ) #! { aceg } { bdfh } -> { abcdefgh } - swap ! error? [ 2array flip concat ] keep like ; : mod-nth ( n seq -- elt ) #! 5 "abcd" -> b - [ length mod ] keep nth ; + [ length mod ] [ nth ] bi ; diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index fa0cbef4c7..eff95bbcd6 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -9,4 +9,3 @@ IN: crypto.hmac.tests [ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test [ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test [ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test - diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 3dad01fe3a..91d404aead 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -37,7 +37,6 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : byte-array>sha1-hmac ( K string -- hmac ) binary stream>sha1-hmac ; - : stream>md5-hmac ( K stream -- hmac ) [ init-hmac md5-hmac ] with-stream ; diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index 7ecbd767b9..45e10da74d 100755 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -3,7 +3,7 @@ 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 ; +io.encodings.binary symbols math.bitfields.lib ; IN: crypto.md5 r bitand r> bitor ; + pick bitnot bitand [ bitand ] [ bitor ] bi* ; : G ( X Y Z -- GXYZ ) #! G(X,Y,Z) = XZ v Y not(Z) - dup bitnot rot bitand >r bitand r> bitor ; + dup bitnot rot bitand [ bitand ] [ bitor ] bi* ; : H ( X Y Z -- HXYZ ) #! H(X,Y,Z) = X xor Y xor Z diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index ccf17da4e8..5d3228db10 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -1,5 +1,5 @@ USING: math.miller-rabin kernel math math.functions namespaces -sequences ; +sequences accessors ; IN: crypto.rsa ! The private key is the only secret. @@ -39,7 +39,7 @@ PRIVATE> public-key ; : rsa-encrypt ( message rsa -- encrypted ) - [ rsa-public-key ] keep rsa-modulus ^mod ; + [ public-key>> ] [ modulus>> ] bi ^mod ; : rsa-decrypt ( encrypted rsa -- message ) - [ rsa-private-key ] keep rsa-modulus ^mod ; \ No newline at end of file + [ private-key>> ] [ modulus>> ] bi ^mod ; diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 8f3d3e6ecc..37e92db60f 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,7 +1,7 @@ USING: arrays combinators crypto.common kernel io io.encodings.binary io.files io.streams.byte-array math.vectors strings sequences namespaces math parser sequences vectors -io.binary hashtables symbols ; +io.binary hashtables symbols math.bitfields.lib ; IN: crypto.sha1 ! Implemented according to RFC 3174. @@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; K get nth , A get 5 bitroll-32 , E get , - ] { } make sum >32-bit ; inline + ] { } make sum 32 bits ; inline : set-vars ( temp -- ) ! E = D; D = C; C = S^30(B); B = A; A = TEMP; @@ -125,4 +125,4 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; [ zero? ] left-trim dup length odd? [ 1 tail ] when seq>2seq [ byte-array>sha1 ] bi@ - swap 2seq>seq ; + 2seq>seq ; diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor index daba6d29ff..0acc5c1388 100755 --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -1,19 +1,19 @@ USING: crypto.common kernel splitting math sequences namespaces -io.binary symbols ; +io.binary symbols math.bitfields.lib ; IN: crypto.sha2 word ; +SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; -: a 0 ; -: b 1 ; -: c 2 ; -: d 3 ; -: e 4 ; -: f 5 ; -: g 6 ; -: h 7 ; +: a 0 ; inline +: b 1 ; inline +: c 2 ; inline +: d 3 ; inline +: e 4 ; inline +: f 5 ; inline +: g 6 ; inline +: h 7 ; inline : initial-H-256 ( -- seq ) { @@ -124,7 +124,6 @@ PRIVATE> initial-H-256 H set 4 word-size set 64 block-size set - \ >32-bit >word set byte-array>sha2 ] with-scope ; diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor index da2603d92c..a17d65d90b 100644 --- a/extra/crypto/timing/timing.factor +++ b/extra/crypto/timing/timing.factor @@ -1,7 +1,6 @@ USING: kernel math threads system ; IN: crypto.timing -: with-timing ( ... quot n -- ) +: with-timing ( quot n -- ) #! force the quotation to execute in, at minimum, n milliseconds - millis 2slip millis - + sleep ; - + millis 2slip millis - + sleep ; inline diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor index 0713e19843..247387ebdf 100644 --- a/extra/crypto/xor/xor.factor +++ b/extra/crypto/xor/xor.factor @@ -1,8 +1,8 @@ USING: crypto.common kernel math sequences ; IN: crypto.xor -TUPLE: no-xor-key ; +ERROR: no-xor-key ; -: xor-crypt ( key seq -- seq ) - over empty? [ no-xor-key construct-empty throw ] when +: xor-crypt ( key seq -- seq' ) + over empty? [ no-xor-key ] when dup length rot [ mod-nth bitxor ] curry 2map ; diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor index 845381a23c..c047393c99 100644 --- a/extra/db/mysql/ffi/ffi.factor +++ b/extra/db/mysql/ffi/ffi.factor @@ -6,9 +6,9 @@ USING: alien alien.syntax combinators kernel system ; IN: db.mysql.ffi << "mysql" { - { [ win32? ] [ "libmySQL.dll" "stdcall" ] } - { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } - { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } + { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] } + { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } + { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] } } cond add-library >> LIBRARY: mysql diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index be491b8c85..7925989bf5 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -5,9 +5,9 @@ USING: alien alien.syntax combinators system ; IN: db.postgresql.ffi << "postgresql" { - { [ win32? ] [ "libpq.dll" ] } - { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } - { [ unix? ] [ "libpq.so" ] } + { [ os winnt? ] [ "libpq.dll" ] } + { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } + { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> ! ConnSatusType diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 1d356b1592..c724025874 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -7,9 +7,9 @@ USING: alien compiler kernel math namespaces sequences strings alien.syntax IN: db.sqlite.ffi << "sqlite" { - { [ winnt? ] [ "sqlite3.dll" ] } - { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } - { [ unix? ] [ "libsqlite3.so" ] } + { [ os winnt? ] [ "sqlite3.dll" ] } + { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } + { [ os unix? ] [ "libsqlite3.so" ] } } cond "cdecl" add-library >> ! Return values from sqlite functions diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index f9b4c8648d..64e133dd2a 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -21,12 +21,5 @@ PROTOCOL: stream-protocol make-cell-stream stream-write-table ; PROTOCOL: definition-protocol - where set-where forget uses redefined* + where set-where forget uses synopsis* definer definition ; - -PROTOCOL: prettyprint-section-protocol - section-fits? indent-section? unindent-first-line? - newline-after? short-section? short-section long-section -
delegate>block add-section ; - - diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index e871d5f808..16de8f5eee 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -3,7 +3,7 @@ USING: parser kernel namespaces sequences definitions io.files inspector continuations tools.crossref tools.vocabs io prettyprint source-files assocs vocabs vocabs.loader -io.backend splitting classes.tuple ; +io.backend splitting accessors ; IN: editors TUPLE: no-edit-hook ; @@ -18,7 +18,7 @@ SYMBOL: edit-hook : editor-restarts ( -- alist ) available-editors - [ "Load " over append swap ] { } map>assoc ; + [ [ "Load " prepend ] keep ] { } map>assoc ; : no-edit-hook ( -- ) \ no-edit-hook construct-empty @@ -26,7 +26,7 @@ SYMBOL: edit-hook require ; : edit-location ( file line -- ) - >r (normalize-path) "\\\\?\\" ?head drop r> + >r (normalize-path) r> edit-hook get [ call ] [ no-edit-hook edit-location ] if* ; : edit ( defspec -- ) @@ -35,18 +35,31 @@ SYMBOL: edit-hook : edit-vocab ( name -- ) vocab-source-path 1 edit-location ; +GENERIC: find-parse-error ( error -- error' ) + +M: parse-error find-parse-error + dup error>> find-parse-error [ ] [ ] ?if ; + +M: condition find-parse-error + error>> find-parse-error ; + +M: object find-parse-error + drop f ; + : :edit ( -- ) - error get delegates [ parse-error? ] find-last nip [ - dup parse-error-file source-file-path - swap parse-error-line edit-location + error get find-parse-error [ + [ file>> path>> ] [ line>> ] bi edit-location ] when* ; : fix ( word -- ) - "Fixing " write dup pprint " and all usages..." print nl - dup usage swap prefix [ - "Editing " write dup . - "RETURN moves on to the next usage, C+d stops." print - flush - edit - readln + [ "Fixing " write pprint " and all usages..." print nl ] + [ [ usage ] keep prefix ] bi + [ + [ "Editing " write . ] + [ + "RETURN moves on to the next usage, C+d stops." print + flush + edit + readln + ] bi ] all? drop ; diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor index 775d008963..62150bdf49 100755 --- a/extra/editors/gvim/gvim.factor +++ b/extra/editors/gvim/gvim.factor @@ -13,6 +13,6 @@ t vim-detach set-global ! don't block the ui T{ gvim } vim-editor set-global { - { [ unix? ] [ "editors.gvim.unix" ] } - { [ windows? ] [ "editors.gvim.windows" ] } + { [ os unix? ] [ "editors.gvim.unix" ] } + { [ os windows? ] [ "editors.gvim.windows" ] } } cond require diff --git a/extra/editors/gvim/unix/unix.factor b/extra/editors/gvim/unix/unix.factor index a7de09c013..3b8f7454c1 100644 --- a/extra/editors/gvim/unix/unix.factor +++ b/extra/editors/gvim/unix/unix.factor @@ -1,7 +1,8 @@ -USING: io.unix.backend kernel namespaces editors.gvim.backend ; +USING: io.unix.backend kernel namespaces editors.gvim.backend +system ; IN: editors.gvim.unix -M: unix-io gvim-path +M: unix gvim-path \ gvim-path get-global [ "gvim" ] unless* ; diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 489000498e..daf5409c94 100755 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -1,8 +1,8 @@ USING: editors.gvim.backend io.files io.windows kernel namespaces -sequences windows.shell32 io.paths ; +sequences windows.shell32 io.paths system ; IN: editors.gvim.windows -M: windows-io gvim-path +M: windows gvim-path \ gvim-path get-global [ program-files "vim" append-path t [ "gvim.exe" tail? ] find-file diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index 92320addef..e4f19781ef 100755 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -4,7 +4,7 @@ USING: arrays definitions io kernel math namespaces parser prettyprint sequences strings words editors io.files io.sockets io.streams.byte-array io.binary math.parser io.encodings.ascii io.encodings.binary -io.encodings.utf8 ; +io.encodings.utf8 io.files.private ; IN: editors.jedit : jedit-server-info ( -- port auth ) diff --git a/extra/editors/textwrangler/authors.txt b/extra/editors/textwrangler/authors.txt new file mode 100644 index 0000000000..b4a113da41 --- /dev/null +++ b/extra/editors/textwrangler/authors.txt @@ -0,0 +1 @@ +Ben Schlingelhof diff --git a/extra/editors/textwrangler/summary.txt b/extra/editors/textwrangler/summary.txt new file mode 100644 index 0000000000..cf502f96e5 --- /dev/null +++ b/extra/editors/textwrangler/summary.txt @@ -0,0 +1 @@ +Textwrangler editor integration diff --git a/extra/editors/textwrangler/textwrangler.factor b/extra/editors/textwrangler/textwrangler.factor new file mode 100644 index 0000000000..e97dadcdcb --- /dev/null +++ b/extra/editors/textwrangler/textwrangler.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Ben Schlingelhof. +! See http://factorcode.org/license.txt for BSD license. +USING: definitions io.launcher kernel parser words sequences +math math.parser namespaces editors ; +IN: editors.textwrangler + +: tw ( file line -- ) + [ "edit +" % # " " % % ] "" make run-process drop ; + +: tw-word ( word -- ) + where first2 tw ; + +[ tw ] edit-hook set-global diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor index 00f7de1370..f34bdc9920 100755 --- a/extra/freetype/freetype.factor +++ b/extra/freetype/freetype.factor @@ -4,8 +4,8 @@ USING: alien alien.syntax kernel system combinators ; IN: freetype << "freetype" { - { [ macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] } - { [ windows? ] [ "freetype6.dll" "cdecl" add-library ] } + { [ os macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] } + { [ os windows? ] [ "freetype6.dll" "cdecl" add-library ] } { [ t ] [ drop ] } } cond >> diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor index 17794c196d..95a56da2d2 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -1,8 +1,7 @@ +USING: system ; IN: hardware-info.backend -SYMBOL: os HOOK: cpus os ( -- n ) - HOOK: memory-load os ( -- n ) HOOK: physical-mem os ( -- n ) HOOK: available-mem os ( -- n ) diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 69b8678749..6d27cf5252 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -1,16 +1,21 @@ -USING: alien.syntax kernel math prettyprint +USING: alien.syntax kernel math prettyprint io math.parser combinators vocabs.loader hardware-info.backend system ; IN: hardware-info -: kb. ( x -- ) 10 2^ /f . ; -: megs. ( x -- ) 20 2^ /f . ; -: gigs. ( x -- ) 30 2^ /f . ; +: write-unit ( x n str -- ) + [ 2^ /i number>string write bl ] [ write ] bi* ; -<< -{ - { [ windows? ] [ "hardware-info.windows" ] } - { [ linux? ] [ "hardware-info.linux" ] } - { [ macosx? ] [ "hardware-info.macosx" ] } +: kb ( x -- ) 10 "kB" write-unit ; +: megs ( x -- ) 20 "MB" write-unit ; +: gigs ( x -- ) 30 "GB" write-unit ; + +<< { + { [ os windows? ] [ "hardware-info.windows" ] } + { [ os linux? ] [ "hardware-info.linux" ] } + { [ os macosx? ] [ "hardware-info.macosx" ] } { [ t ] [ f ] } } cond [ require ] when* >> +: hardware-report. ( -- ) + "CPUs: " write cpus number>string write nl + "Physical RAM: " write physical-mem megs nl ; diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor index c246a95186..dac052a1de 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/hardware-info/macosx/macosx.factor @@ -1,10 +1,8 @@ USING: alien alien.c-types alien.syntax byte-arrays kernel -namespaces sequences unix hardware-info.backend ; +namespaces sequences unix hardware-info.backend system +io.unix.backend ; IN: hardware-info.macosx -TUPLE: macosx ; -T{ macosx } os set-global - ! See /usr/include/sys/sysctl.h for constants LIBRARY: libc @@ -14,14 +12,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi [ ] map concat ; : (sysctl-query) ( name namelen oldp oldlenp -- oldp error/f ) - over >r - f 0 sysctl -1 = [ err_no strerror ] [ f ] if - r> swap ; + over >r f 0 sysctl io-error r> ; : sysctl-query ( seq n -- byte-array ) - >r [ make-int-array ] keep length r> - [ ] keep - (sysctl-query) [ throw ] when* ; + >r [ make-int-array ] [ length ] bi r> + [ ] [ ] bi (sysctl-query) ; : sysctl-query-string ( seq -- n ) 4096 sysctl-query alien>char-string ; @@ -36,8 +31,15 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi : model ( -- str ) { 6 2 } sysctl-query-string ; M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ; : byte-order ( -- n ) { 6 4 } sysctl-query-uint ; -: user-mem ( -- n ) { 6 4 } sysctl-query-uint ; +M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ; +: user-mem ( -- n ) { 6 6 } sysctl-query-uint ; : page-size ( -- n ) { 6 7 } sysctl-query-uint ; +: disknames ( -- n ) { 6 8 } 8 sysctl-query ; +: diskstats ( -- n ) { 6 9 } 8 sysctl-query ; +: epoch ( -- n ) { 6 10 } sysctl-query-uint ; +: floating-point ( -- n ) { 6 11 } sysctl-query-uint ; +: machine-arch ( -- n ) { 6 12 } sysctl-query-string ; +: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ; : bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ; : cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ; : cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ; @@ -47,7 +49,7 @@ M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ; : l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ; : l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ; : l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ; -: bus-frequency2 ( -- n ) { 6 23 } sysctl-query-uint ; -M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ; +: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ; +: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ; : available-cpus ( -- n ) { 6 25 } sysctl-query-uint ; diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index f671ea9426..c61a3c8b8a 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -1,34 +1,31 @@ USING: alien.c-types hardware-info kernel math namespaces -windows windows.kernel32 hardware-info.backend ; +windows windows.kernel32 hardware-info.backend system ; IN: hardware-info.windows.ce -TUPLE: wince-os ; -T{ wince-os } os set-global - : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength [ GlobalMemoryStatus ] keep ; -M: wince-os cpus ( -- n ) 1 ; +M: wince cpus ( -- n ) 1 ; -M: wince-os memory-load ( -- n ) +M: wince memory-load ( -- n ) memory-status MEMORYSTATUS-dwMemoryLoad ; -M: wince-os physical-mem ( -- n ) +M: wince physical-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalPhys ; -M: wince-os available-mem ( -- n ) +M: wince available-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailPhys ; -M: wince-os total-page-file ( -- n ) +M: wince total-page-file ( -- n ) memory-status MEMORYSTATUS-dwTotalPageFile ; -M: wince-os available-page-file ( -- n ) +M: wince available-page-file ( -- n ) memory-status MEMORYSTATUS-dwAvailPageFile ; -M: wince-os total-virtual-mem ( -- n ) +M: wince total-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalVirtual ; -M: wince-os available-virtual-mem ( -- n ) +M: wince available-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailVirtual ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 8bdb75fe6a..ba9c1d74b5 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,15 +1,12 @@ USING: alien alien.c-types kernel libc math namespaces hardware-info.backend -windows windows.advapi32 windows.kernel32 ; +windows windows.advapi32 windows.kernel32 system ; IN: hardware-info.windows.nt -TUPLE: winnt-os ; -T{ winnt-os } os set-global - : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; -M: winnt-os cpus ( -- n ) +M: winnt cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) @@ -17,25 +14,25 @@ M: winnt-os cpus ( -- n ) "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; -M: winnt-os memory-load ( -- n ) +M: winnt memory-load ( -- n ) memory-status MEMORYSTATUSEX-dwMemoryLoad ; -M: winnt-os physical-mem ( -- n ) +M: winnt physical-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPhys ; -M: winnt-os available-mem ( -- n ) +M: winnt available-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPhys ; -M: winnt-os total-page-file ( -- n ) +M: winnt total-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPageFile ; -M: winnt-os available-page-file ( -- n ) +M: winnt available-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPageFile ; -M: winnt-os total-virtual-mem ( -- n ) +M: winnt total-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalVirtual ; -M: winnt-os available-virtual-mem ( -- n ) +M: winnt available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; : computer-name ( -- string ) diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index f3a1eb33f5..807fd158ba 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -65,6 +65,6 @@ IN: hardware-info.windows << { - { [ wince? ] [ "hardware-info.windows.ce" ] } - { [ winnt? ] [ "hardware-info.windows.nt" ] } + { [ os wince? ] [ "hardware-info.windows.ce" ] } + { [ os winnt? ] [ "hardware-info.windows.nt" ] } } cond [ require ] when* >> diff --git a/extra/help/crossref/crossref.factor b/extra/help/crossref/crossref.factor index e347fde051..0b17461a99 100644 --- a/extra/help/crossref/crossref.factor +++ b/extra/help/crossref/crossref.factor @@ -14,7 +14,7 @@ M: link uses collect-elements [ \ f or ] map ; : help-path ( topic -- seq ) - [ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ; + [ article-parent ] follow 1 tail ; : set-article-parents ( parent article -- ) article-children [ set-article-parent ] with each ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 1c2dfde85c..acdbca82ee 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -2,7 +2,8 @@ USING: help help.markup help.syntax help.definitions help.topics namespaces words sequences classes assocs vocabs kernel arrays prettyprint.backend kernel.private io generic math system strings sbufs vectors byte-arrays bit-arrays float-arrays -quotations io.streams.byte-array io.encodings.string ; +quotations io.streams.byte-array io.encodings.string +classes.builtin ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -152,6 +153,7 @@ ARTICLE: "collections" "Collections" "Implementations:" { $subsection "hashtables" } { $subsection "alists" } +{ $subsection "enums" } { $heading "Other collections" } { $subsection "boxes" } { $subsection "dlists" } @@ -261,7 +263,7 @@ ARTICLE: "handbook" "Factor documentation" { $subsection "collections" } { $subsection "io" } { $subsection "concurrency" } -{ $subsection "os" } +{ $subsection "system" } { $subsection "alien" } { $heading "Environment reference" } { $subsection "cli" } diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index a180a28f23..06a3ec8dd2 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -42,6 +42,6 @@ PRIVATE> [ with-directory ] curry keep delete-tree ; inline { - { [ unix? ] [ "io.unix.files.unique" ] } - { [ windows? ] [ "io.windows.files.unique" ] } + { [ os unix? ] [ "io.unix.files.unique" ] } + { [ os windows? ] [ "io.windows.files.unique" ] } } cond require diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 79382091ab..20c5bb92c9 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -6,7 +6,7 @@ init threads continuations math io.encodings io.streams.duplex io.nonblocking accessors ; IN: io.launcher -TUPLE: process +TUPLE: process < identity-tuple command detached @@ -65,8 +65,6 @@ M: object register-process drop ; V{ } clone over processes get set-at register-process ; -M: process equal? 2drop f ; - M: process hashcode* process-handle hashcode* ; : pass-environment? ( process -- ? ) diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index 8480fcd856..5b0790ca2d 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -6,8 +6,8 @@ alien.c-types combinators namespaces alien parser ; IN: io.sockets.impl << { - { [ windows? ] [ "windows.winsock" ] } - { [ unix? ] [ "unix" ] } + { [ os windows? ] [ "windows.winsock" ] } + { [ os unix? ] [ "unix" ] } } cond use+ >> GENERIC: protocol-family ( addrspec -- af ) @@ -96,14 +96,13 @@ M: inet6 parse-sockaddr M: f parse-sockaddr nip ; : addrinfo>addrspec ( addrinfo -- addrspec ) - dup addrinfo-addr - swap addrinfo-family addrspec-of-family + [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi parse-sockaddr ; : parse-addrinfo-list ( addrinfo -- seq ) - [ dup ] - [ dup addrinfo-next swap addrinfo>addrspec ] - [ ] unfold nip [ ] subset ; + [ addrinfo-next ] follow + [ addrinfo>addrspec ] map + [ ] subset ; : prepare-resolve-host ( host serv passive? -- host' serv' flags ) #! If the port is a number, we resolve for 'http' then diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 63d2adbdf7..865490b0ce 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -8,8 +8,6 @@ qualified namespaces io.timeouts io.encodings.utf8 accessors ; QUALIFIED: io IN: io.unix.backend -MIXIN: unix-io - ! I/O tasks TUPLE: io-task port callbacks ; @@ -120,7 +118,7 @@ M: integer close-handle ( fd -- ) [ dup reads>> handle-timeout ] [ dup writes>> handle-timeout ] 2bi ; -M: unix-io cancel-io ( port -- ) +M: unix cancel-io ( port -- ) mx get-global cancel-io-tasks ; ! Readers @@ -180,10 +178,10 @@ M: write-task do-io-task M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; -M: unix-io io-multiplex ( ms/f -- ) +M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; -M: unix-io (init-stdio) ( -- ) +M: unix (init-stdio) ( -- ) 0 1 2 ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 89b0757da5..6f6517868e 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -3,7 +3,7 @@ IN: io.unix.bsd USING: io.backend io.unix.backend io.unix.kqueue io.unix.select io.launcher io.unix.launcher namespaces kernel assocs -threads continuations ; +threads continuations system ; ! On Mac OS X, we use select() for the top-level ! multiplexer, and we hang a kqueue off of it for process exit @@ -12,16 +12,12 @@ threads continuations ; ! kqueue is buggy with files and ptys so we can't use it as the ! main multiplexer. -MIXIN: bsd-io - -INSTANCE: bsd-io unix-io - -M: bsd-io init-io ( -- ) +M: bsd init-io ( -- ) mx set-global kqueue-mx set-global kqueue-mx get-global dup io-task-fd 2dup mx get-global mx-reads set-at mx get-global mx-writes set-at ; -M: bsd-io register-process ( process -- ) +M: bsd register-process ( process -- ) process-handle kqueue-mx get-global add-pid-task ; diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index a0310a1cac..040b191d27 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -22,8 +22,8 @@ IN: io.unix.files.tests [ "/lib" ] [ "/" "../../lib" append-path ] unit-test [ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test -{ [ "/lib" ] [ "/usr/" "/lib" append-path ] } -{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] } -{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] } -{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] } -{ [ t ] [ "/foo" absolute-path? ] } +[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test +[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test +[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test +[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test +[ t ] [ "/foo" absolute-path? ] unit-test diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 7d0e7c4330..39c18b4601 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -3,15 +3,16 @@ USING: io.backend io.nonblocking io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitfields byte-arrays alien combinators calendar -io.encodings.binary accessors sequences strings ; +io.encodings.binary accessors sequences strings system +io.files.private ; IN: io.unix.files -M: unix-io cwd ( -- path ) +M: unix cwd ( -- path ) MAXPATHLEN [ ] [ ] bi getcwd [ (io-error) ] unless* ; -M: unix-io cd ( path -- ) +M: unix cd ( path -- ) chdir io-error ; : read-flags O_RDONLY ; inline @@ -19,7 +20,7 @@ M: unix-io cd ( path -- ) : open-read ( path -- fd ) O_RDONLY file-mode open dup io-error ; -M: unix-io (file-reader) ( path -- stream ) +M: unix (file-reader) ( path -- stream ) open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline @@ -27,7 +28,7 @@ M: unix-io (file-reader) ( path -- stream ) : open-write ( path -- fd ) write-flags file-mode open dup io-error ; -M: unix-io (file-writer) ( path -- stream ) +M: unix (file-writer) ( path -- stream ) open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline @@ -36,28 +37,28 @@ M: unix-io (file-writer) ( path -- stream ) append-flags file-mode open dup io-error [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; -M: unix-io (file-appender) ( path -- stream ) +M: unix (file-appender) ( path -- stream ) open-append ; : touch-mode ( -- n ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable -M: unix-io touch-file ( path -- ) +M: unix touch-file ( path -- ) normalize-path touch-mode file-mode open dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when close ; -M: unix-io move-file ( from to -- ) +M: unix move-file ( from to -- ) [ normalize-path ] bi@ rename io-error ; -M: unix-io delete-file ( path -- ) +M: unix delete-file ( path -- ) normalize-path unlink io-error ; -M: unix-io make-directory ( path -- ) +M: unix make-directory ( path -- ) normalize-path OCT: 777 mkdir io-error ; -M: unix-io delete-directory ( path -- ) +M: unix delete-directory ( path -- ) normalize-path rmdir io-error ; : (copy-file) ( from to -- ) @@ -68,7 +69,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ] with-disposal ; -M: unix-io copy-file ( from to -- ) +M: unix copy-file ( from to -- ) [ normalize-path ] bi@ [ (copy-file) ] [ swap file-info file-info-permissions chmod io-error ] @@ -95,16 +96,16 @@ M: unix-io copy-file ( from to -- ) } cleave \ file-info construct-boa ; -M: unix-io file-info ( path -- info ) +M: unix file-info ( path -- info ) normalize-path stat* stat>file-info ; -M: unix-io link-info ( path -- info ) +M: unix link-info ( path -- info ) normalize-path lstat* stat>file-info ; -M: unix-io make-link ( path1 path2 -- ) +M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; -M: unix-io read-link ( path -- path' ) +M: unix read-link ( path -- path' ) normalize-path PATH_MAX [ tuck ] [ ] bi readlink dup io-error head-slice >string ; diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index c5365d8d5c..035e6398ee 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -1,11 +1,11 @@ USING: kernel io.nonblocking io.unix.backend math.bitfields -unix io.files.unique.backend ; +unix io.files.unique.backend system ; IN: io.unix.files.unique : open-unique-flags ( -- flags ) { O_RDWR O_CREAT O_EXCL } flags ; -M: unix-io (make-unique-file) ( path -- ) +M: unix (make-unique-file) ( path -- ) open-unique-flags file-mode open dup io-error close ; -M: unix-io temporary-path ( -- path ) "/tmp" ; +M: unix temporary-path ( -- path ) "/tmp" ; diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor index 65b4a6f0f7..49fbc9af7e 100644 --- a/extra/io/unix/freebsd/freebsd.factor +++ b/extra/io/unix/freebsd/freebsd.factor @@ -1,8 +1,3 @@ -IN: io.unix.freebsd -USING: io.unix.bsd io.backend ; +USING: io.unix.bsd io.backend system ; -TUPLE: freebsd-io ; - -INSTANCE: freebsd-io bsd-io - -T{ freebsd-io } set-io-backend +freebsd set-io-backend diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 4986024e78..5f0a9b96cb 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend io.unix.files io.nonblocking sequences kernel namespaces math system alien.c-types debugger continuations arrays assocs combinators unix.process strings threads unix -io.unix.launcher.parser accessors io.files ; +io.unix.launcher.parser accessors io.files io.files.private ; IN: io.unix.launcher ! Search unix first @@ -79,12 +79,12 @@ USE: unix (io-error) ] [ 255 exit ] recover ; -M: unix-io current-process-handle ( -- handle ) getpid ; +M: unix current-process-handle ( -- handle ) getpid ; -M: unix-io run-process* ( process -- pid ) +M: unix run-process* ( process -- pid ) [ spawn-process ] curry [ ] with-fork ; -M: unix-io kill-process* ( pid -- ) +M: unix kill-process* ( pid -- ) SIGTERM kill io-error ; : open-pipe ( -- pair ) @@ -95,7 +95,7 @@ M: unix-io kill-process* ( pid -- ) 2dup first close second close >r first 0 dup2 drop r> second 1 dup2 drop ; -M: unix-io (process-stream) +M: unix (process-stream) >r open-pipe open-pipe r> [ >r setup-stdio-pipe r> spawn-process ] curry [ -rot 2dup second close first close ] diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 2ae4065fb6..78af0dd50d 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -4,13 +4,9 @@ USING: kernel io.backend io.monitors io.monitors.private io.files io.buffers io.nonblocking io.timeouts io.unix.backend io.unix.select io.unix.launcher unix.linux.inotify assocs namespaces threads continuations init math alien.c-types alien -vocabs.loader accessors ; +vocabs.loader accessors system ; IN: io.unix.linux -TUPLE: linux-io ; - -INSTANCE: linux-io unix-io - TUPLE: linux-monitor ; : ( wd -- monitor ) @@ -24,8 +20,10 @@ TUPLE: inotify watches ; : ( -- port/f ) H{ } clone - inotify_init [ io-error ] [ inotify ] bi - { set-inotify-watches set-delegate } inotify construct ; + inotify_init dup 0 < [ 2drop f ] [ + inotify + { set-inotify-watches set-delegate } inotify construct + ] if ; : inotify-fd inotify get-global handle>> ; @@ -50,7 +48,7 @@ TUPLE: inotify watches ; "inotify is not supported by this Linux release" throw ] unless ; -M: linux-io ( path recursive? -- monitor ) +M: linux ( path recursive? -- monitor ) check-inotify drop IN_CHANGE_EVENTS add-watch ; @@ -109,18 +107,21 @@ TUPLE: inotify-task ; f inotify-task ; : init-inotify ( mx -- ) - - dup inotify set-global - swap register-io-task ; + dup [ + dup inotify set-global + swap register-io-task + ] [ + 2drop + ] if ; M: inotify-task do-io-task ( task -- ) io-task-port read-notifications f ; -M: linux-io init-io ( -- ) +M: linux init-io ( -- ) [ mx set-global ] - [ [ init-inotify ] curry ignore-errors ] bi ; + [ init-inotify ] bi ; -T{ linux-io } set-io-backend +linux set-io-backend [ start-wait-thread ] "io.unix.linux" add-init-hook diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index bd48fbc9b5..c1c73ea018 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,13 +1,9 @@ -IN: io.unix.macosx USING: io.unix.bsd io.backend io.monitors io.monitors.private continuations kernel core-foundation.fsevents sequences -namespaces arrays ; +namespaces arrays system ; +IN: io.unix.macosx -TUPLE: macosx-io ; - -INSTANCE: macosx-io bsd-io - -T{ macosx-io } set-io-backend +macosx set-io-backend TUPLE: macosx-monitor ; @@ -16,7 +12,7 @@ TUPLE: macosx-monitor ; [ [ first { +modify-file+ } swap changed-file ] each ] bind notify-callback ; -M: macosx-io +M: macosx drop f macosx-monitor construct-simple-monitor dup [ enqueue-notifications ] curry diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 71c55f2303..f042366b13 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -10,12 +10,12 @@ IN: io.unix.mmap >r f -roll r> open-r/w [ 0 mmap ] keep over MAP_FAILED = [ close (io-error) ] when ; -M: unix-io ( path length -- obj ) +M: unix ( path length -- obj ) swap >r dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor r> mmap-open f mapped-file construct-boa ; -M: unix-io close-mapped-file ( mmap -- ) +M: unix close-mapped-file ( mmap -- ) [ mapped-file-address ] keep [ mapped-file-length munmap ] keep mapped-file-handle close diff --git a/extra/io/unix/netbsd/netbsd.factor b/extra/io/unix/netbsd/netbsd.factor index 3aa8678702..c5771c8ffc 100644 --- a/extra/io/unix/netbsd/netbsd.factor +++ b/extra/io/unix/netbsd/netbsd.factor @@ -1,8 +1,3 @@ -IN: io.unix.netbsd -USING: io.unix.bsd io.backend ; +USING: io.backend system ; -TUPLE: netbsd-io ; - -INSTANCE: netbsd-io bsd-io - -T{ netbsd-io } set-io-backend +netbsd set-io-backend diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor index 767861ec75..9b3021646d 100644 --- a/extra/io/unix/openbsd/openbsd.factor +++ b/extra/io/unix/openbsd/openbsd.factor @@ -1,8 +1,3 @@ -IN: io.unix.openbsd -USING: io.unix.bsd io.backend core-foundation.fsevents ; +USING: io.unix.bsd io.backend core-foundation.fsevents system ; -TUPLE: openbsd-io ; - -INSTANCE: openbsd-io bsd-io - -T{ openbsd-io } set-io-backend +openbsd set-io-backend diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 69ce6a3069..a54205a878 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces io.nonblocking parser threads unix sequences byte-arrays io.sockets io.binary io.unix.backend io.streams.duplex io.sockets.impl math.parser continuations libc -combinators io.backend io.files ; +combinators io.backend io.files io.files.private system ; IN: io.unix.sockets : pending-init-error ( port -- ) @@ -23,7 +23,7 @@ IN: io.unix.sockets : sockopt ( fd level opt -- ) 1 "int" heap-size setsockopt io-error ; -M: unix-io addrinfo-error ( n -- ) +M: unix addrinfo-error ( n -- ) dup zero? [ drop ] [ gai_strerror throw ] if ; ! Client sockets - TCP and Unix domain @@ -42,7 +42,7 @@ M: connect-task do-io-task : wait-to-connect ( port -- ) [ add-io-task ] with-port-continuation drop ; -M: unix-io (client) ( addrspec -- client-in client-out ) +M: unix (client) ( addrspec -- client-in client-out ) dup make-sockaddr/size >r >r protocol-family SOCK_STREAM socket-fd dup r> r> connect @@ -91,11 +91,11 @@ USE: io.sockets dup rot make-sockaddr/size bind zero? [ dup close (io-error) ] unless ; -M: unix-io (server) ( addrspec -- handle ) +M: unix (server) ( addrspec -- handle ) SOCK_STREAM server-fd dup 10 listen zero? [ dup close (io-error) ] unless ; -M: unix-io (accept) ( server -- addrspec handle ) +M: unix (accept) ( server -- addrspec handle ) #! Wait for a client connection. dup check-server-port dup wait-to-accept @@ -104,7 +104,7 @@ M: unix-io (accept) ( server -- addrspec handle ) swap server-port-client ; ! Datagram sockets - UDP and Unix domain -M: unix-io +M: unix [ SOCK_DGRAM server-fd ] keep ; SYMBOL: receive-buffer @@ -147,7 +147,7 @@ M: receive-task do-io-task : wait-receive ( stream -- ) [ add-io-task ] with-port-continuation drop ; -M: unix-io receive ( datagram -- packet addrspec ) +M: unix receive ( datagram -- packet addrspec ) dup check-datagram-port dup wait-receive dup pending-error @@ -179,7 +179,7 @@ M: send-task do-io-task [ add-io-task ] with-port-continuation 2drop 2drop ; -M: unix-io send ( packet addrspec datagram -- ) +M: unix send ( packet addrspec datagram -- ) 3dup check-datagram-send [ >r make-sockaddr/size r> wait-send ] keep pending-error ; diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 0a7fc72662..b4328f31b3 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts io.unix.launcher io.unix.mmap io.backend combinators namespaces -system vocabs.loader sequences ; +system vocabs.loader sequences words ; -"io.unix." os append require +"io.unix." os word-name append require diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 152e76a6c7..a8ff4c14e3 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -7,10 +7,10 @@ IN: io.windows.ce.backend : port-errored ( port -- ) win32-error-string swap set-port-error ; -M: windows-ce-io io-multiplex ( ms -- ) +M: wince io-multiplex ( ms -- ) 60 60 * 1000 * or (sleep) ; -M: windows-ce-io add-completion ( handle -- ) drop ; +M: wince add-completion ( handle -- ) drop ; GENERIC: wince-read ( port port-handle -- ) @@ -26,18 +26,18 @@ M: port port-flush dup dup port-handle wince-write port-flush ] if ; -M: windows-ce-io init-io ( -- ) +M: wince init-io ( -- ) init-winsock ; LIBRARY: libc FUNCTION: void* _getstdfilex int fd ; FUNCTION: void* _fileno void* file ; -M: windows-ce-io (init-stdio) ( -- ) +M: wince (init-stdio) ( -- ) #! We support Windows NT too, to make this I/O backend #! easier to debug. 512 default-buffer-size [ - winnt? [ + os winnt? [ STD_INPUT_HANDLE GetStdHandle STD_OUTPUT_HANDLE GetStdHandle STD_ERROR_HANDLE GetStdHandle diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index 878f5899f6..a0a8de8513 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -1,7 +1,11 @@ -USING: io.backend io.windows io.windows.ce.backend -io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher -namespaces io.windows.mmap ; -IN: io.windows.ce - +USE: io.backend +USE: io.windows +USE: io.windows.ce.backend +USE: io.windows.ce.files +USE: io.windows.ce.sockets +USE: io.windows.ce.launcher +USE: io.windows.mmap system USE: io.windows.files -T{ windows-ce-io } set-io-backend +USE: system + +wince set-io-backend diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index 1e5cedae57..8f7390aa7c 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -1,15 +1,15 @@ USING: alien alien.c-types combinators io io.backend io.buffers io.files io.nonblocking io.windows kernel libc math namespaces prettyprint sequences strings threads threads.private -windows windows.kernel32 io.windows.ce.backend ; +windows windows.kernel32 io.windows.ce.backend system ; IN: windows.ce.files -! M: windows-ce-io normalize-path ( string -- string ) +! M: wince normalize-path ( string -- string ) ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ; -M: windows-ce-io CreateFile-flags ( DWORD -- DWORD ) +M: wince CreateFile-flags ( DWORD -- DWORD ) FILE_ATTRIBUTE_NORMAL bitor ; -M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ; +M: wince FileArgs-overlapped ( port -- f ) drop f ; : finish-read ( port status bytes-ret -- ) swap [ drop port-errored ] [ swap n>buffer ] if ; diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 9bc583a3d8..0001bb5142 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -2,11 +2,11 @@ USING: alien alien.c-types combinators io io.backend io.buffers io.nonblocking io.sockets io.sockets.impl io.windows kernel libc math namespaces prettyprint qualified sequences strings threads threads.private windows windows.kernel32 io.windows.ce.backend -byte-arrays ; +byte-arrays system ; QUALIFIED: windows.winsock IN: io.windows.ce -M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ; +M: wince WSASocket-flags ( -- DWORD ) 0 ; M: win32-socket wince-read ( port port-handle -- ) win32-file-handle over buffer-end pick buffer-capacity 0 @@ -31,15 +31,15 @@ M: win32-socket wince-write ( port port-handle -- ) windows.winsock:WSAConnect windows.winsock:winsock-error!=0/f ; -M: windows-ce-io (client) ( addrspec -- reader writer ) +M: wince (client) ( addrspec -- reader writer ) do-connect dup ; -M: windows-ce-io (server) ( addrspec -- handle ) +M: wince (server) ( addrspec -- handle ) windows.winsock:SOCK_STREAM server-fd dup listen-on-socket ; -M: windows-ce-io (accept) ( server -- client ) +M: wince (accept) ( server -- client ) [ dup check-server-port [ @@ -55,7 +55,7 @@ M: windows-ce-io (accept) ( server -- client ) ] with-timeout ; -M: windows-ce-io ( addrspec -- datagram ) +M: wince ( addrspec -- datagram ) [ windows.winsock:SOCK_DGRAM server-fd ] keep ; @@ -81,7 +81,7 @@ M: windows-ce-io ( addrspec -- datagram ) packet-size receive-buffer set-global -M: windows-ce-io receive ( datagram -- packet addrspec ) +M: wince receive ( datagram -- packet addrspec ) dup check-datagram-port [ port-handle win32-file-handle @@ -104,7 +104,7 @@ M: windows-ce-io receive ( datagram -- packet addrspec ) dup length receive-buffer rot pick memcpy receive-buffer make-WSABUF ; -M: windows-ce-io send ( packet addrspec datagram -- ) +M: wince send ( packet addrspec datagram -- ) 3dup check-datagram-send port-handle win32-file-handle rot send-WSABUF diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index a23a78b3da..8bfbff2ba0 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types io.backend io.files io.windows kernel math windows windows.kernel32 windows.time calendar combinators -math.functions sequences namespaces words symbols -combinators.lib io.nonblocking destructors ; +math.functions sequences namespaces words symbols system +combinators.lib io.nonblocking destructors math.bitfields.lib ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ @@ -88,10 +88,10 @@ SYMBOLS: +read-only+ +hidden+ +system+ get-file-information BY_HANDLE_FILE_INFORMATION>file-info ] if ; -M: windows-nt-io file-info ( path -- info ) +M: winnt file-info ( path -- info ) normalize-path get-file-information-stat ; -M: windows-nt-io link-info ( path -- info ) +M: winnt link-info ( path -- info ) file-info ; : file-times ( path -- timestamp timestamp timestamp ) @@ -125,7 +125,7 @@ M: windows-nt-io link-info ( path -- info ) : set-file-write-time ( path timestamp -- ) >r f f r> set-file-times ; -M: windows-nt-io touch-file ( path -- ) +M: winnt touch-file ( path -- ) [ normalize-path maybe-create-file over close-always diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 7e7610eb72..0449980286 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -2,9 +2,9 @@ USING: kernel system io.files.unique.backend windows.kernel32 io.windows io.nonblocking windows ; IN: io.windows.files.unique -M: windows-io (make-unique-file) ( path -- ) +M: windows (make-unique-file) ( path -- ) GENERIC_WRITE CREATE_NEW 0 open-file CloseHandle win32-error=0/f ; -M: windows-io temporary-path ( -- path ) +M: windows temporary-path ( -- path ) "TEMP" os-env ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 579745710e..07ce6c308a 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays continuations destructors io +USING: alien alien.c-types arrays continuations io io.windows io.windows.nt.pipes libc io.nonblocking -io.streams.duplex windows.types math windows.kernel32 windows -namespaces io.launcher kernel sequences windows.errors assocs +io.streams.duplex windows.types math windows.kernel32 +namespaces io.launcher kernel sequences windows.errors splitting system threads init strings combinators -io.backend accessors concurrency.flags io.files ; +io.backend accessors concurrency.flags io.files assocs +io.files.private windows destructors ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -27,8 +28,7 @@ TUPLE: CreateProcess-args "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo "PROCESS_INFORMATION" >>lpProcessInformation TRUE >>bInheritHandles - 0 >>dwCreateFlags - current-directory get (normalize-path) >>lpCurrentDirectory ; + 0 >>dwCreateFlags ; : call-CreateProcess ( CreateProcess-args -- ) { @@ -82,7 +82,7 @@ TUPLE: CreateProcess-args : fill-dwCreateFlags ( process args -- process args ) 0 pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when - pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when + pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when pick lookup-priority [ bitor ] when* >>dwCreateFlags ; @@ -101,28 +101,29 @@ TUPLE: CreateProcess-args HOOK: fill-redirection io-backend ( process args -- ) -M: windows-ce-io fill-redirection 2drop ; +M: wince fill-redirection 2drop ; : make-CreateProcess-args ( process -- args ) default-CreateProcess-args - wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if + os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if fill-dwCreateFlags fill-lpEnvironment fill-startup-info nip ; -M: windows-io current-process-handle ( -- handle ) +M: windows current-process-handle ( -- handle ) GetCurrentProcessId ; -M: windows-io run-process* ( process -- handle ) +M: windows run-process* ( process -- handle ) [ dup make-CreateProcess-args tuck fill-redirection + current-directory get (normalize-path) cd dup call-CreateProcess lpProcessInformation>> ] with-destructors ; -M: windows-io kill-process* ( handle -- ) +M: windows kill-process* ( handle -- ) PROCESS_INFORMATION-hProcess 255 TerminateProcess win32-error=0/f ; @@ -161,7 +162,7 @@ SYMBOL: wait-flag wait-flag set-global [ wait-loop t ] "Process wait" spawn-server drop ; -M: windows-io register-process +M: windows register-process drop wait-flag get-global raise-flag ; [ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index d1cafa4c0f..8d3690bbb5 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types alien.syntax arrays continuations destructors generic io.mmap io.nonblocking io.windows kernel libc math namespaces quotations sequences windows -windows.advapi32 windows.kernel32 io.backend ; +windows.advapi32 windows.kernel32 io.backend system ; IN: io.windows.mmap TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES @@ -53,11 +53,11 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES HOOK: with-privileges io-backend ( seq quot -- ) inline -M: windows-nt-io with-privileges +M: winnt with-privileges over [ [ t set-privilege ] each ] curry compose swap [ [ f set-privilege ] each ] curry [ ] cleanup ; -M: windows-ce-io with-privileges +M: wince with-privileges nip call ; : mmap-open ( path access-mode create-mode flProtect access -- handle handle address ) @@ -70,7 +70,7 @@ M: windows-ce-io with-privileges dup close-later ] with-privileges ; -M: windows-io ( path length -- mmap ) +M: windows ( path length -- mmap ) [ swap GENERIC_WRITE GENERIC_READ bitor @@ -81,7 +81,7 @@ M: windows-io ( path length -- mmap ) f \ mapped-file construct-boa ] with-destructors ; -M: windows-io close-mapped-file ( mapped-file -- ) +M: windows close-mapped-file ( mapped-file -- ) [ dup mapped-file-handle [ close-always ] each mapped-file-address UnmapViewOfFile win32-error=0/f diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index dcd13895b2..822973b85b 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -3,7 +3,7 @@ continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences threads classes.tuple.lib windows windows.errors windows.kernel32 strings splitting io.files qualified ascii -combinators.lib ; +combinators.lib system ; QUALIFIED: windows.winsock IN: io.windows.nt.backend @@ -28,7 +28,7 @@ SYMBOL: master-completion-port : ( -- handle ) INVALID_HANDLE_VALUE f ; -M: windows-nt-io add-completion ( handle -- ) +M: winnt add-completion ( handle -- ) master-completion-port get-global drop ; : eof? ( error -- ? ) @@ -89,13 +89,13 @@ M: windows-nt-io add-completion ( handle -- ) : drain-overlapped ( timeout -- ) handle-overlapped [ 0 drain-overlapped ] unless ; -M: windows-nt-io cancel-io +M: winnt cancel-io port-handle win32-file-handle CancelIo drop ; -M: windows-nt-io io-multiplex ( ms -- ) +M: winnt io-multiplex ( ms -- ) drain-overlapped ; -M: windows-nt-io init-io ( -- ) +M: winnt init-io ( -- ) master-completion-port set-global H{ } clone io-hash set-global windows.winsock:init-winsock ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 91ad0139b2..3232ab6ff3 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,22 +1,23 @@ USING: continuations destructors io.buffers io.files io.backend io.timeouts io.nonblocking io.windows io.windows.nt.backend -kernel libc math threads windows windows.kernel32 +kernel libc math threads windows windows.kernel32 system alien.c-types alien.arrays sequences combinators combinators.lib -sequences.lib ascii splitting alien strings assocs namespaces ; +sequences.lib ascii splitting alien strings assocs namespaces +io.files.private ; IN: io.windows.nt.files -M: windows-nt-io cwd +M: winnt cwd MAX_UNICODE_PATH dup "ushort" [ GetCurrentDirectory win32-error=0/f ] keep alien>u16-string ; -M: windows-nt-io cd +M: winnt cd SetCurrentDirectory win32-error=0/f ; : unicode-prefix ( -- seq ) "\\\\?\\" ; inline -M: windows-nt-io root-directory? ( path -- ? ) +M: winnt root-directory? ( path -- ? ) { { [ dup empty? ] [ f ] } { [ dup [ path-separator? ] all? ] [ t ] } @@ -40,15 +41,15 @@ ERROR: not-absolute-path ; unicode-prefix prepend ] unless ; -M: windows-nt-io normalize-path ( string -- string' ) +M: winnt normalize-path ( string -- string' ) (normalize-path) { { CHAR: / CHAR: \\ } } substitute prepend-prefix ; -M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) +M: winnt CreateFile-flags ( DWORD -- DWORD ) FILE_FLAG_OVERLAPPED bitor ; -M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) +M: winnt FileArgs-overlapped ( port -- overlapped ) make-overlapped ; : update-file-ptr ( n port -- ) diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 895890e898..4bbf7c8e32 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -112,13 +112,13 @@ IN: io.windows.nt.launcher dup pipe-out f set-inherit >>stdin-pipe ; -M: windows-nt-io fill-redirection ( process args -- ) +M: winnt fill-redirection ( process args -- ) [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput 2drop ; -M: windows-nt-io (process-stream) +M: winnt (process-stream) [ dup make-CreateProcess-args diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 83e062c3a9..164b529b61 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations io.monitors io.monitors.private io.nonblocking io.buffers io.files io.timeouts io sequences hashtables sorting arrays -combinators math.bitfields strings ; +combinators math.bitfields strings system ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) @@ -30,7 +30,7 @@ TUPLE: win32-monitor path recursive? ; set-delegate } win32-monitor construct ; -M: windows-nt-io ( path recursive? -- monitor ) +M: winnt ( path recursive? -- monitor ) [ over open-directory win32-monitor diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 1baec5658f..33bb3a88b9 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -11,5 +11,6 @@ USE: io.windows.nt.sockets USE: io.windows.mmap USE: io.windows.files USE: io.backend +USE: system -T{ windows-nt-io } set-io-backend +winnt set-io-backend diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 85bb34b225..36acaac992 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -2,13 +2,13 @@ USING: alien alien.accessors alien.c-types byte-arrays continuations destructors io.nonblocking io.timeouts io.sockets io.sockets.impl io namespaces io.streams.duplex io.windows io.windows.nt.backend windows.winsock kernel libc math sequences -threads classes.tuple.lib ; +threads classes.tuple.lib system ; IN: io.windows.nt.sockets : malloc-int ( object -- object ) "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline -M: windows-nt-io WSASocket-flags ( -- DWORD ) +M: winnt WSASocket-flags ( -- DWORD ) WSA_FLAG_OVERLAPPED ; : get-ConnectEx-ptr ( socket -- void* ) @@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port 2dup save-callback get-overlapped-result drop ; -M: windows-nt-io (client) ( addrspec -- client-in client-out ) +M: winnt (client) ( addrspec -- client-in client-out ) [ \ ConnectEx-args construct-empty over make-sockaddr/size pick init-connect @@ -119,7 +119,7 @@ TUPLE: AcceptEx-args port [ AcceptEx-args-sAcceptSocket* add-completion ] keep AcceptEx-args-sAcceptSocket* ; -M: windows-nt-io (accept) ( server -- addrspec handle ) +M: winnt (accept) ( server -- addrspec handle ) [ [ dup check-server-port @@ -131,14 +131,14 @@ M: windows-nt-io (accept) ( server -- addrspec handle ) ] with-timeout ] with-destructors ; -M: windows-nt-io (server) ( addrspec -- handle ) +M: winnt (server) ( addrspec -- handle ) [ SOCK_STREAM server-fd dup listen-on-socket dup add-completion ] with-destructors ; -M: windows-nt-io ( addrspec -- datagram ) +M: winnt ( addrspec -- datagram ) [ [ SOCK_DGRAM server-fd @@ -190,7 +190,7 @@ TUPLE: WSARecvFrom-args port [ WSARecvFrom-args-lpFrom* ] keep WSARecvFrom-args-port datagram-port-addr parse-sockaddr ; -M: windows-nt-io receive ( datagram -- packet addrspec ) +M: winnt receive ( datagram -- packet addrspec ) [ dup check-datagram-port \ WSARecvFrom-args construct-empty @@ -242,7 +242,7 @@ TUPLE: WSASendTo-args port USE: io.sockets -M: windows-nt-io send ( packet addrspec datagram -- ) +M: winnt send ( packet addrspec datagram -- ) [ 3dup check-datagram-send \ WSASendTo-args construct-empty diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 45c1adaf50..3e0f4e9e86 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -5,16 +5,12 @@ io.buffers io.files io.nonblocking io.sockets io.binary io.sockets.impl windows.errors strings io.streams.duplex kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting -continuations math.bitfields ; +continuations math.bitfields system ; IN: io.windows -TUPLE: windows-nt-io ; -TUPLE: windows-ce-io ; -UNION: windows-io windows-nt-io windows-ce-io ; +M: windows destruct-handle CloseHandle drop ; -M: windows-io destruct-handle CloseHandle drop ; - -M: windows-io destruct-socket closesocket drop ; +M: windows destruct-socket closesocket drop ; TUPLE: win32-file handle ptr ; @@ -24,7 +20,7 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) -M: windows-io normalize-directory ( string -- string ) +M: windows normalize-directory ( string -- string ) normalize-path "\\" ?tail drop "\\*" append ; : share-mode ( -- fixnum ) @@ -36,7 +32,8 @@ M: windows-io normalize-directory ( string -- string ) : default-security-attributes ( -- obj ) "SECURITY_ATTRIBUTES" - "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ; + "SECURITY_ATTRIBUTES" heap-size + over set-SECURITY_ATTRIBUTES-nLength ; : security-attributes-inherit ( -- obj ) default-security-attributes @@ -51,8 +48,8 @@ M: win32-file close-handle ( handle -- ) ! Clean up resources (open handle) if add-completion fails : open-file ( path access-mode create-mode flags -- handle ) [ - >r >r - share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile + >r >r share-mode security-attributes-inherit r> r> + CreateFile-flags f CreateFile dup invalid-handle? dup close-later dup add-completion ] with-destructors ; @@ -99,7 +96,8 @@ M: win32-file close-handle ( handle -- ) >r (open-append) r> 2dup set-file-pointer ; TUPLE: FileArgs - hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ; + hFile lpBuffer nNumberOfBytesToRead + lpNumberOfBytesRet lpOverlapped ; C: FileArgs @@ -125,30 +123,30 @@ C: FileArgs [ FileArgs-lpNumberOfBytesRet ] keep FileArgs-lpOverlapped ; -M: windows-io (file-reader) ( path -- stream ) +M: windows (file-reader) ( path -- stream ) open-read ; -M: windows-io (file-writer) ( path -- stream ) +M: windows (file-writer) ( path -- stream ) open-write ; -M: windows-io (file-appender) ( path -- stream ) +M: windows (file-appender) ( path -- stream ) open-append ; -M: windows-io move-file ( from to -- ) +M: windows move-file ( from to -- ) [ normalize-path ] bi@ MoveFile win32-error=0/f ; -M: windows-io delete-file ( path -- ) +M: windows delete-file ( path -- ) normalize-path DeleteFile win32-error=0/f ; -M: windows-io copy-file ( from to -- ) +M: windows copy-file ( from to -- ) dup parent-directory make-directories [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ; -M: windows-io make-directory ( path -- ) +M: windows make-directory ( path -- ) normalize-path f CreateDirectory win32-error=0/f ; -M: windows-io delete-directory ( path -- ) +M: windows delete-directory ( path -- ) normalize-path RemoveDirectory win32-error=0/f ; @@ -194,9 +192,8 @@ USE: namespaces M: win32-socket dispose ( stream -- ) win32-file-handle closesocket drop ; -M: windows-io addrinfo-error ( n -- ) +M: windows addrinfo-error ( n -- ) winsock-return-check ; : tcp-socket ( addrspec -- socket ) protocol-family SOCK_STREAM open-socket ; - diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index f642d8881c..d13848498f 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -78,7 +78,7 @@ M: lazy-cons nil? ( lazy-cons -- bool ) swap [ cdr ] times car ; : (llength) ( list acc -- n ) - over nil? [ nip ] [ >r cdr r> 1+ (llength) ] if ; + over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; : llength ( list -- n ) 0 (llength) ; @@ -273,7 +273,7 @@ M: lazy-from-by car ( lazy-from-by -- car ) M: lazy-from-by cdr ( lazy-from-by -- cdr ) [ lazy-from-by-n ] keep - lazy-from-by-quot dup >r call r> lfrom-by ; + lazy-from-by-quot dup slip lfrom-by ; M: lazy-from-by nil? ( lazy-from-by -- bool ) drop f ; @@ -370,10 +370,10 @@ M: lazy-concat nil? ( lazy-concat -- bool ) ] if ; : lcomp ( list quot -- result ) - >r lcartesian-product* r> lmap ; + [ lcartesian-product* ] dip lmap ; : lcomp* ( list guards quot -- result ) - >r >r lcartesian-product* r> [ lsubset ] each r> lmap ; + [ [ lcartesian-product* ] dip [ lsubset ] each ] dip lmap ; DEFER: lmerge @@ -382,7 +382,7 @@ DEFER: lmerge [ dup [ car ] curry -rot [ - >r cdr r> cdr lmerge + [ cdr ] bi@ lmerge ] 2curry lazy-cons ] 2curry lazy-cons ; @@ -419,7 +419,7 @@ M: lazy-io cdr ( lazy-io -- cdr ) [ lazy-io-stream ] keep [ lazy-io-quot ] keep car [ - >r f f r> [ swap set-lazy-io-cdr ] keep + [ f f ] dip [ swap set-lazy-io-cdr ] keep ] [ 3drop nil ] if diff --git a/extra/math/bitfields/lib/lib-docs.factor b/extra/math/bitfields/lib/lib-docs.factor new file mode 100644 index 0000000000..bfbe9eaded --- /dev/null +++ b/extra/math/bitfields/lib/lib-docs.factor @@ -0,0 +1,16 @@ +USING: help.markup help.syntax kernel math sequences ; +IN: math.bitfields.lib + +HELP: bits +{ $values { "m" integer } { "n" integer } { "m'" integer } } +{ $description "Keep only n bits from the integer m." } +{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ; + +HELP: bitroll +{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } +{ $description "Roll n by s bits to the left, wrapping around after w bits." } +{ $examples + { $example "USING: math.bitfields.lib prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } + { $example "USING: math.bitfields.lib prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } +} ; + diff --git a/extra/crypto/test/common.factor b/extra/math/bitfields/lib/lib-tests.factor similarity index 85% rename from extra/crypto/test/common.factor rename to extra/math/bitfields/lib/lib-tests.factor index 6050454402..c002240e69 100644 --- a/extra/crypto/test/common.factor +++ b/extra/math/bitfields/lib/lib-tests.factor @@ -1,4 +1,5 @@ -USING: kernel math test namespaces crypto ; +USING: math.bitfields.lib tools.test ; +IN: math.bitfields.lib.test [ 0 ] [ 1 0 0 bitroll ] unit-test [ 1 ] [ 1 0 1 bitroll ] unit-test @@ -11,5 +12,3 @@ USING: kernel math test namespaces crypto ; [ 1 ] [ 1 -32 8 bitroll ] unit-test [ 128 ] [ 1 -1 8 bitroll ] unit-test [ 8 ] [ 1 3 32 bitroll ] unit-test - - diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor new file mode 100644 index 0000000000..72b33b9ae7 --- /dev/null +++ b/extra/math/bitfields/lib/lib.factor @@ -0,0 +1,30 @@ +USING: hints kernel math ; +IN: math.bitfields.lib + +: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable +: set-bit ( x n -- y ) 2^ bitor ; foldable +: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable +: unmask ( x n -- ? ) bitnot bitand ; foldable +: unmask? ( x n -- ? ) unmask 0 > ; foldable +: mask ( x n -- ? ) bitand ; foldable +: mask? ( x n -- ? ) mask 0 > ; foldable +: wrap ( m n -- m' ) 1- bitand ; foldable +: bits ( m n -- m' ) 2^ wrap ; inline +: mask-bit ( m n -- m' ) 1- 2^ mask ; inline + +: shift-mod ( n s w -- n ) + >r shift r> 2^ wrap ; inline + +: bitroll ( x s w -- y ) + [ wrap ] keep + [ shift-mod ] + [ [ - ] keep shift-mod ] 3bi bitor ; inline + +: bitroll-32 ( n s -- n' ) 32 bitroll ; + +HINTS: bitroll-32 bignum fixnum ; + +: bitroll-64 ( n s -- n' ) 64 bitroll ; + +HINTS: bitroll-64 bignum fixnum ; + diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index dcbccb4316..77c7d9247d 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -30,15 +30,6 @@ M: real sqrt 2dup >r >r >r odd? r> call r> 2/ r> each-bit ] if ; inline -: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable -: set-bit ( x n -- y ) 2^ bitor ; foldable -: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable -: bit-set? ( x n -- ? ) bit-clear? not ; foldable -: unmask ( x n -- ? ) bitnot bitand ; foldable -: unmask? ( x n -- ? ) unmask 0 > ; foldable -: mask ( x n -- ? ) bitand ; foldable -: mask? ( x n -- ? ) mask 0 > ; foldable - GENERIC: (^) ( x y -- z ) foldable : ^n ( z w -- z^w ) diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index 685124e4e9..eeb1b66a89 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -45,7 +45,7 @@ PRIVATE> : primes-between ( low high -- seq ) primes-upto - >r 1- next-prime r> + [ 1- next-prime ] dip [ [ <=> ] binsearch ] keep [ length ] keep ; foldable : coprime? ( a b -- ? ) gcd nip 1 = ; foldable diff --git a/extra/models/models.factor b/extra/models/models.factor index fd84dd248f..ffb9b1127a 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -4,13 +4,12 @@ USING: generic kernel math sequences arrays assocs alarms calendar ; IN: models -TUPLE: model value connections dependencies ref locked? ; +TUPLE: model < identity-tuple +value connections dependencies ref locked? ; : ( value -- model ) V{ } clone V{ } clone 0 f model construct-boa ; -M: model equal? 2drop f ; - M: model hashcode* drop model hashcode* ; : add-dependency ( dep model -- ) diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor index 830249a3df..37dd30f7fd 100644 --- a/extra/ogg/ogg.factor +++ b/extra/ogg/ogg.factor @@ -6,9 +6,9 @@ IN: ogg << "ogg" { - { [ win32? ] [ "ogg.dll" ] } - { [ macosx? ] [ "libogg.0.dylib" ] } - { [ unix? ] [ "libogg.so" ] } + { [ os winnt? ] [ "ogg.dll" ] } + { [ os macosx? ] [ "libogg.0.dylib" ] } + { [ os unix? ] [ "libogg.so" ] } } cond "cdecl" add-library >> diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor index 48b61b41a3..3d73fb8820 100644 --- a/extra/ogg/theora/theora.factor +++ b/extra/ogg/theora/theora.factor @@ -6,9 +6,9 @@ IN: ogg.theora << "theora" { - { [ win32? ] [ "theora.dll" ] } - { [ macosx? ] [ "libtheora.0.dylib" ] } - { [ unix? ] [ "libtheora.so" ] } + { [ os winnt? ] [ "theora.dll" ] } + { [ os macosx? ] [ "libtheora.0.dylib" ] } + { [ os unix? ] [ "libtheora.so" ] } } cond "cdecl" add-library >> diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor index 170d0ea6ef..5712272ebc 100644 --- a/extra/ogg/vorbis/vorbis.factor +++ b/extra/ogg/vorbis/vorbis.factor @@ -6,9 +6,9 @@ IN: ogg.vorbis << "vorbis" { - { [ win32? ] [ "vorbis.dll" ] } - { [ macosx? ] [ "libvorbis.0.dylib" ] } - { [ unix? ] [ "libvorbis.so" ] } + { [ os winnt? ] [ "vorbis.dll" ] } + { [ os macosx? ] [ "libvorbis.0.dylib" ] } + { [ os unix? ] [ "libvorbis.so" ] } } cond "cdecl" add-library >> diff --git a/extra/openal/backend/backend.factor b/extra/openal/backend/backend.factor index edbb227fcc..41069dcddf 100644 --- a/extra/openal/backend/backend.factor +++ b/extra/openal/backend/backend.factor @@ -1,8 +1,4 @@ -USING: namespaces ; +USING: namespaces system ; IN: openal.backend -SYMBOL: openal-backend -HOOK: load-wav-file openal-backend ( filename -- format data size frequency ) - -TUPLE: other-openal-backend ; -T{ other-openal-backend } openal-backend set-global +HOOK: load-wav-file os ( filename -- format data size frequency ) diff --git a/extra/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor index 7828021f53..d2a0422d8d 100644 --- a/extra/openal/macosx/macosx.factor +++ b/extra/openal/macosx/macosx.factor @@ -1,18 +1,14 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -IN: openal.macosx -USING: alien.c-types kernel alien alien.syntax shuffle -combinators.lib openal.backend namespaces ; - -TUPLE: macosx-openal-backend ; -LIBRARY: alut - -T{ macosx-openal-backend } openal-backend set-global - -FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ; - -M: macosx-openal-backend load-wav-file ( path -- format data size frequency ) - 0 f 0 0 - [ alutLoadWAVFile ] 4keep - >r >r >r *int r> *void* r> *int r> *int ; +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types kernel alien alien.syntax shuffle +combinators.lib openal.backend namespaces system ; +IN: openal.macosx + +LIBRARY: alut + +FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ; + +M: macosx load-wav-file ( path -- format data size frequency ) + 0 f 0 0 + [ alutLoadWAVFile ] 4keep + >r >r >r *int r> *void* r> *int r> *int ; diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index f7b97d2bf5..ff67a30ea3 100644 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -1,21 +1,24 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -! -IN: openal USING: kernel alien system combinators alien.syntax namespaces alien.c-types sequences vocabs.loader shuffle combinators.lib openal.backend ; +IN: openal << "alut" { - { [ win32? ] [ "alut.dll" ] } - { [ macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] } - { [ unix? ] [ "libalut.so" ] } + { [ os windows? ] [ "alut.dll" ] } + { [ os macosx? ] [ + "/System/Library/Frameworks/OpenAL.framework/OpenAL" + ] } + { [ os unix? ] [ "libalut.so" ] } } cond "cdecl" add-library >> << "openal" { - { [ win32? ] [ "OpenAL32.dll" ] } - { [ macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] } - { [ unix? ] [ "libopenal.so" ] } + { [ os windows? ] [ "OpenAL32.dll" ] } + { [ os macosx? ] [ + "/System/Library/Frameworks/OpenAL.framework/OpenAL" + ] } + { [ os unix? ] [ "libopenal.so" ] } } cond "cdecl" add-library >> LIBRARY: openal @@ -257,7 +260,7 @@ SYMBOL: init "create-buffer-from-file failed" throw ] when ; -macosx? "openal.macosx" "openal.other" ? require +os macosx? "openal.macosx" "openal.other" ? require : create-buffer-from-wav ( filename -- buffer ) gen-buffer dup rot load-wav-file @@ -290,4 +293,3 @@ macosx? "openal.macosx" "openal.other" ? require : source-playing? ( source -- bool ) AL_SOURCE_STATE get-source-param AL_PLAYING = ; - diff --git a/extra/openal/other/other.factor b/extra/openal/other/other.factor index e32b007973..d0429fb3c3 100644 --- a/extra/openal/other/other.factor +++ b/extra/openal/other/other.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -IN: openal.other -USING: openal.backend alien.c-types kernel alien alien.syntax shuffle combinators.lib ; - -LIBRARY: alut - -FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ; - -M: other-openal-backend load-wav-file ( filename -- format data size frequency ) - 0 f 0 0 - [ 0 alutLoadWAVFile ] 4keep - >r >r >r *int r> *void* r> *int r> *int ; +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: openal.backend alien.c-types kernel alien alien.syntax +shuffle combinators.lib ; +IN: openal.other + +LIBRARY: alut + +FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ; + +M: object load-wav-file ( filename -- format data size frequency ) + 0 f 0 0 + [ 0 alutLoadWAVFile ] 4keep + >r >r >r *int r> *void* r> *int r> *int ; diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index fd9be4eb12..b0a683dac6 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -1,11 +1,13 @@ USING: alien alien.syntax combinators kernel parser sequences system words namespaces hashtables init math arrays assocs sequences.lib continuations ; + +ERROR: unknown-gl-platform ; << { - { [ windows? ] [ "opengl.gl.windows" ] } - { [ macosx? ] [ "opengl.gl.macosx" ] } - { [ unix? ] [ "opengl.gl.unix" ] } - { [ t ] [ "Unknown OpenGL platform" throw ] } + { [ os windows? ] [ "opengl.gl.windows" ] } + { [ os macosx? ] [ "opengl.gl.macosx" ] } + { [ os unix? ] [ "opengl.gl.unix" ] } + { [ t ] [ unknown-gl-platform ] } } cond use+ >> IN: opengl.gl.extensions diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor index d06afdc5ea..312c7b04b3 100755 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -11,9 +11,9 @@ IN: openssl.libcrypto << "libcrypto" { - { [ win32? ] [ "libeay32.dll" "cdecl" ] } - { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] } - { [ unix? ] [ "libcrypto.so" "cdecl" ] } + { [ os winnt? ] [ "libeay32.dll" "cdecl" ] } + { [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] } + { [ os unix? ] [ "libcrypto.so" "cdecl" ] } } cond add-library >> diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 11dcee31f6..0f2e7b3184 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl << "libssl" { - { [ win32? ] [ "ssleay32.dll" "cdecl" ] } - { [ macosx? ] [ "libssl.dylib" "cdecl" ] } - { [ unix? ] [ "libssl.so" "cdecl" ] } + { [ os winnt? ] [ "ssleay32.dll" "cdecl" ] } + { [ os macosx? ] [ "libssl.dylib" "cdecl" ] } + { [ os unix? ] [ "libssl.so" "cdecl" ] } } cond add-library >> : X509_FILETYPE_PEM 1 ; inline diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor index e5313d5b77..7af69a97bb 100644 --- a/extra/oracle/liboci/liboci.factor +++ b/extra/oracle/liboci/liboci.factor @@ -12,9 +12,9 @@ USING: alien alien.syntax combinators kernel system ; IN: oracle.liboci "oci" { - { [ win32? ] [ "oci.dll" "stdcall" ] } - { [ macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] } - { [ unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] } + { [ os winnt? ] [ "oci.dll" "stdcall" ] } + { [ os macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] } + { [ os unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] } } cond add-library ! =============================================== diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index f5ba0fd11d..65912244dd 100755 --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -1,8 +1,7 @@ USING: alien alien.c-types arrays assocs byte-arrays inference -inference.transforms io io.binary io.streams.string kernel -math math.parser namespaces parser prettyprint -quotations sequences strings vectors -words macros math.functions ; +inference.transforms io io.binary io.streams.string kernel math +math.parser namespaces parser prettyprint quotations sequences +strings vectors words macros math.functions math.bitfields.lib ; IN: pack SYMBOL: big-endian diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 4f802c5207..0879ecda49 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.ebnf words math math.parser ; +USING: kernel tools.test peg peg.ebnf words math math.parser sequences ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ @@ -180,6 +180,55 @@ IN: peg.ebnf.tests { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast ] unit-test +{ f } [ + "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call +] unit-test + +{ V{ "a" " " "b" } } [ + "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "\t" "b" } } [ + "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "\n" "b" } } [ + "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" f "b" } } [ + "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" " " "b" } } [ + "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast +] unit-test + + +{ V{ "a" "\t" "b" } } [ + "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "\n" "b" } } [ + "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "b" } } [ + "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "b" } } [ + "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "b" } } [ + "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ f } [ + "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call +] unit-test + { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used @@ -198,9 +247,13 @@ IN: peg.ebnf.tests "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast ] unit-test +{ t } [ + "abcd='9' | ('8'):x => [[ drop x ]]" 'ebnf' parse parse-result-remaining empty? +] unit-test + EBNF: primary Primary = PrimaryNoNewArray -PrimaryNoNewArray = ClassInstanceCreationExpression +PrimaryNoNewArray = ClassInstanceCreationExpression | MethodInvocation | FieldAccess | ArrayAccess @@ -211,7 +264,7 @@ MethodInvocation = Primary "." MethodName "(" ")" | MethodName "(" ")" FieldAccess = Primary "." Identifier | "super" "." Identifier -ArrayAccess = Primary "[" Expression "]" +ArrayAccess = Primary "[" Expression "]" | ExpressionName "[" Expression "]" ClassOrInterfaceType = ClassName | InterfaceTypeName ClassName = "C" | "D" diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 4f00edbd3c..e5787e6cf8 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -3,7 +3,7 @@ USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg peg.parsers unicode.categories multiline combinators.lib - splitting accessors effects sequences.deep ; + splitting accessors effects sequences.deep peg.search ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -213,6 +213,7 @@ DEFER: 'choice' : 'actioned-sequence' ( -- parser ) [ [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 ] action , + [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , "=>" syntax , 'action' , ] seq* [ first3 >r r> ] action , [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , 'sequence' , ] choice* ; @@ -237,22 +238,21 @@ GENERIC: (transform) ( ast -- parser ) SYMBOL: parser SYMBOL: main -SYMBOL: vars : transform ( ast -- object ) - H{ } clone dup dup [ parser set V{ } vars set swap (transform) main set ] bind ; + H{ } clone dup dup [ parser set swap (transform) main set ] bind ; M: ebnf (transform) ( ast -- parser ) rules>> [ (transform) ] map peek ; M: ebnf-rule (transform) ( ast -- parser ) dup elements>> - vars get clone vars [ (transform) ] with-variable [ + (transform) [ swap symbol>> set ] keep ; M: ebnf-sequence (transform) ( ast -- parser ) - elements>> [ (transform) ] map seq ; + elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ; M: ebnf-choice (transform) ( ast -- parser ) options>> [ (transform) ] map choice ; @@ -282,37 +282,62 @@ M: ebnf-repeat1 (transform) ( ast -- parser ) M: ebnf-optional (transform) ( ast -- parser ) transform-group optional ; -: build-locals ( string vars -- string ) - dup empty? [ - drop - ] [ +GENERIC: build-locals ( code ast -- code ) + +M: ebnf-sequence build-locals ( code ast -- code ) + elements>> dup [ ebnf-var? ] subset empty? [ + drop + ] [ [ - "USING: locals namespaces ; [let* | " % - [ dup % " [ \"" % % "\" get ] " % ] each - " | " % - % - " ] with-locals" % + "USING: locals sequences ; [let* | " % + dup length swap [ + dup ebnf-var? [ + name>> % + " [ " % # " over nth ] " % + ] [ + 2drop + ] if + ] 2each + " | " % + % + " ] with-locals" % ] "" make ] if ; +M: ebnf-var build-locals ( code ast -- ) + [ + "USING: locals kernel ; [let* | " % + name>> % " [ dup ] " % + " | " % + % + " ] with-locals" % + ] "" make ; + +M: object build-locals ( code ast -- ) + drop ; + M: ebnf-action (transform) ( ast -- parser ) - [ parser>> (transform) ] keep - code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ; + [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals + string-lines [ parse-lines ] with-compilation-unit action ; M: ebnf-semantic (transform) ( ast -- parser ) - [ parser>> (transform) ] keep - code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ; + [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals + string-lines [ parse-lines ] with-compilation-unit semantic ; M: ebnf-var (transform) ( ast -- parser ) - [ parser>> (transform) ] [ name>> ] bi - dup vars get push [ dupd set ] curry action ; + parser>> (transform) ; M: ebnf-terminal (transform) ( ast -- parser ) - symbol>> token sp ; + symbol>> token ; + +: parser-not-found ( name -- * ) + [ + "Parser " % % " not found." % + ] "" make throw ; M: ebnf-non-terminal (transform) ( ast -- parser ) symbol>> [ - , parser get , \ at , \ sp , + , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip , ] [ ] make box ; : transform-ebnf ( string -- object ) @@ -320,7 +345,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : check-parse-result ( result -- result ) dup [ - dup parse-result-remaining empty? [ + dup parse-result-remaining [ blank? ] trim empty? [ [ "Unable to fully parse EBNF. Left to parse was: " % parse-result-remaining % @@ -335,10 +360,16 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) parse-result-ast transform dup dup parser [ main swap at compile ] with-variable [ compiled-parse ] curry [ with-scope ] curry ; -: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing +: replace-escapes ( string -- string ) + "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ; + +: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing : EBNF: CREATE-WORD dup - ";EBNF" parse-multiline-string + ";EBNF" parse-multiline-string replace-escapes ebnf>quot swapd 1 1 define-declared "ebnf-parser" set-word-prop ; parsing +: rule ( name word -- parser ) + #! Given an EBNF word produced from EBNF: return the EBNF rule + "ebnf-parser" word-prop at ; \ No newline at end of file diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3e0ce815f0..217805ce47 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -30,6 +30,14 @@ SYMBOL: fail SYMBOL: lrstack SYMBOL: heads +: delegates ( -- cache ) + \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; + +: reset-pegs ( -- ) + H{ } clone \ delegates set-global ; + +reset-pegs + TUPLE: memo-entry ans pos ; C: memo-entry @@ -253,14 +261,6 @@ SYMBOL: id 1 id set-global 0 ] if* ; -: delegates ( -- cache ) - \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; - -: reset-delegates ( -- ) - H{ } clone \ delegates set-global ; - -reset-delegates - : init-parser ( parser -- parser ) #! Set the delegate for the parser. Equivalent parsers #! get a delegate with the same id. @@ -590,7 +590,13 @@ PRIVATE> #! not a cached one. This is because the same box, #! compiled twice can have a different compiled word #! due to running at compile time. - box-parser construct-boa next-id f over set-delegate ; + #! Why the [ ] action at the end? Box parsers don't get + #! memoized during parsing due to all box parsers being + #! unique. This breaks left recursion detection during the + #! parse. The action adds an indirection with a parser type + #! that gets memoized and fixes this. Need to rethink how + #! to fix boxes so this isn't needed... + box-parser construct-boa next-id f over set-delegate [ ] action ; : PEG: (:) [ diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index b3d2135da7..88993c354b 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -1,9 +1,45 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.pl0 multiline sequences ; +USING: kernel tools.test peg peg.ebnf peg.pl0 multiline sequences ; IN: peg.pl0.tests +{ t } [ + "CONST foo = 1;" "block" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "VAR foo;" "block" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "VAR foo,bar , baz;" "block" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "BEGIN foo := 5 END" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse parse-result-remaining empty? +] unit-test + { t } [ <" VAR x, squ; diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index f7eb3cad23..1b97814ca7 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -7,20 +7,52 @@ IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 EBNF: pl0 -block = ( "CONST" ident "=" number ( "," ident "=" number )* ";" )? - ( "VAR" ident ( "," ident )* ";" )? - ( "PROCEDURE" ident ";" ( block ";" )? )* statement -statement = ( ident ":=" expression | "CALL" ident | - "BEGIN" statement (";" statement )* "END" | - "IF" condition "THEN" statement | - "WHILE" condition "DO" statement )? -condition = "ODD" expression | - expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression -expression = ("+" | "-")? term (("+" | "-") term )* -term = factor (("*" | "/") factor )* -factor = ident | number | "(" expression ")" -ident = (([a-zA-Z])+) [[ >string ]] -digit = ([0-9]) [[ digit> ]] -number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]] -program = block "." +_ = (" " | "\t" | "\n")* => [[ drop ignore ]] + +BEGIN = "BEGIN" _ +CALL = "CALL" _ +CONST = "CONST" _ +DO = "DO" _ +END = "END" _ +IF = "IF" _ +THEN = "THEN" _ +ODD = "ODD" _ +PROCEDURE = "PROCEDURE" _ +VAR = "VAR" _ +WHILE = "WHILE" _ +EQ = "=" _ +LTEQ = "<=" _ +LT = "<" _ +GT = ">" _ +GTEQ = ">=" _ +NEQ = "#" _ +COMMA = "," _ +SEMICOLON = ";" _ +ASSIGN = ":=" _ + +ADD = "+" _ +SUBTRACT = "-" _ +MULTIPLY = "*" _ +DIVIDE = "/" _ + +LPAREN = "(" _ +RPAREN = ")" _ + +block = ( CONST ident EQ number ( COMMA ident EQ number )* SEMICOLON )? + ( VAR ident ( COMMA ident )* SEMICOLON )? + ( PROCEDURE ident SEMICOLON ( block SEMICOLON )? )* statement +statement = ( ident ASSIGN expression + | CALL ident + | BEGIN statement ( SEMICOLON statement )* END + | IF condition THEN statement + | WHILE condition DO statement )? +condition = ODD expression + | expression (EQ | NEQ | LTEQ | LT | GTEQ | GT) expression +expression = (ADD | SUBTRACT)? term ( (ADD | SUBTRACT) term )* _ +term = factor ( (MULTIPLY | DIVIDE) factor )* +factor = ident | number | LPAREN expression RPAREN +ident = (([a-zA-Z])+) _ => [[ >string ]] +digit = ([0-9]) => [[ digit> ]] +number = ((digit)+) _ => [[ 10 digits>integer ]] +program = _ block "." ;EBNF diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor index 61645bf50b..90655149dc 100644 --- a/extra/project-euler/169/169.factor +++ b/extra/project-euler/169/169.factor @@ -30,7 +30,7 @@ MEMO: fn ( n -- x ) { { [ dup 2 < ] [ drop 1 ] } { [ dup odd? ] [ 2/ fn ] } - { [ t ] [ 2/ [ fn ] keep 1- fn + ] } + { [ t ] [ 2/ [ fn ] [ 1- fn + ] bi + ] } } cond ; : euler169 ( -- result ) diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor index f7eac4c32d..5ca2c79afe 100755 --- a/extra/random-tester/safe-words/safe-words.factor +++ b/extra/random-tester/safe-words/safe-words.factor @@ -52,11 +52,6 @@ IN: random-tester.safe-words >r r> } ; -: method-words - { - forget-word - } ; - : stateful-words { counter @@ -82,7 +77,6 @@ IN: random-tester.safe-words bignum-words % initialization-words % stack-words % - method-words % stateful-words % exit-words % foo-words % diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 8ddbdac6f4..46f2088440 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c - USING: arrays kernel math namespaces sequences system init -accessors math.ranges random ; +accessors math.ranges random circular math.bitfields.lib +combinators ; IN: random.mersenne-twister = [ - ] [ drop ] if ; inline -: mt-wrap ( x -- y ) mt-n wrap ; inline -: set-generated ( y from-elt to seq -- ) - >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi - r> bitxor bitxor r> r> set-nth ; inline +: calculate-y ( n seq -- y ) + [ nth 32 mask-bit ] + [ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline -: calculate-y ( y1 y2 mt -- y ) - tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline - -: (mt-generate) ( n mt-seq -- y to from-elt ) - [ >r dup 1+ mt-wrap r> calculate-y ] - [ >r mt-m + mt-wrap r> nth ] - [ drop ] 2tri ; +: (mt-generate) ( n seq -- next-mt ) + [ + calculate-y + [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor + ] [ + [ mt-m + ] [ nth ] bi* + ] 2bi bitxor ; : mt-generate ( mt -- ) - [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ] - [ 0 >>i drop ] bi ; + [ + mt-n swap seq>> [ + [ (mt-generate) ] [ set-nth ] 2bi + ] curry each + ] [ 0 >>i drop ] bi ; -: init-mt-first ( seed -- seq ) - >r mt-n 0 r> - HEX: ffffffff bitand 0 pick set-nth ; - -: init-mt-formula ( seq i -- f(seq[i]) ) - tuck swap nth dup -30 shift bitxor 1812433253 * + - 1+ HEX: ffffffff bitand ; +: init-mt-formula ( i seq -- f(seq[i]) ) + dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; : init-mt-rest ( seq -- ) - mt-n 1- [0,b) [ - dupd [ init-mt-formula ] keep 1+ rot set-nth - ] with each ; + mt-n 1- swap [ + [ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi + ] curry each ; : init-mt-seq ( seed -- seq ) - init-mt-first dup init-mt-rest ; + 32 bits mt-n 0 + [ set-first ] [ init-mt-rest ] [ ] tri ; : mt-temper ( y -- yt ) dup -11 shift bitxor @@ -57,6 +52,9 @@ TUPLE: mersenne-twister seq i ; dup 15 shift HEX: efc60000 bitand bitxor dup -18 shift bitxor ; inline +: next-index ( mt -- i ) + dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; + PRIVATE> : ( seed -- obj ) @@ -67,7 +65,6 @@ M: mersenne-twister seed-random ( mt seed -- ) init-mt-seq >>seq drop ; M: mersenne-twister random-32* ( mt -- r ) - dup [ i>> ] [ seq>> ] bi - over mt-n < [ nip >r dup mt-generate 0 r> ] unless - nth mt-temper - swap [ 1+ ] change-i drop ; + [ next-index ] + [ seq>> nth mt-temper ] + [ [ 1+ ] change-i drop ] tri ; diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 3be2697bdf..6a72baa21b 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -15,7 +15,7 @@ C: unix-random M: unix-random random-bytes* ( n tuple -- byte-array ) path>> file-read-unbuffered ; -os "openbsd" = [ +os openbsd? [ [ "/dev/srandom" secure-random-generator set-global "/dev/prandom" insecure-random-generator set-global diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 7e9496c90d..6921d1223a 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -136,7 +136,7 @@ M: lambda-word word-noise-factor : flatten-generics ( words -- words' ) [ - dup generic? [ methods values ] [ 1array ] if + dup generic? [ "methods" word-prop values ] [ 1array ] if ] map concat ; : noisy-words ( -- alist ) diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index a705a9609e..1d22ed731a 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -3,6 +3,12 @@ smtp.server kernel sequences namespaces logging accessors assocs sorting ; IN: smtp.tests +[ t ] [ + + dup clone "a" "b" set-header drop + headers>> assoc-empty? +] unit-test + { 0 0 } [ [ ] with-smtp-connection ] must-infer-as [ "hello\nworld" validate-address ] must-fail diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 13db422621..ee2b021329 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -106,7 +106,7 @@ LOG: smtp-response DEBUG TUPLE: email from to subject headers body ; M: email clone - (clone) [ clone ] change-headers ; + call-next-method [ clone ] change-headers ; : (send) ( email -- ) [ diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 395c4ff924..e11d16c4ec 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -107,6 +107,4 @@ DEFER: ?make-staging-image make-boot-image deploy-command-line run-factor ; -SYMBOL: deploy-implementation - -HOOK: deploy* deploy-implementation ( vocab -- ) +HOOK: deploy* os ( vocab -- ) diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index f12512f510..893b43844a 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -5,5 +5,5 @@ IN: tools.deploy : deploy ( vocab -- ) deploy* ; -macosx? [ "tools.deploy.macosx" require ] when -winnt? [ "tools.deploy.windows" require ] when +os macosx? [ "tools.deploy.macosx" require ] when +os winnt? [ "tools.deploy.windows" require ] when diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 6d9c8e9d8a..3a7f8e5d03 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -50,17 +50,13 @@ IN: tools.deploy.macosx : bundle-name ( -- string ) deploy-name get ".app" append ; -TUPLE: macosx-deploy-implementation ; - -T{ macosx-deploy-implementation } deploy-implementation set-global - : show-in-finder ( path -- ) NSWorkspace -> sharedWorkspace over rot parent-directory -> selectFile:inFileViewerRootedAtPath: drop ; -M: macosx-deploy-implementation deploy* ( vocab -- ) +M: macosx deploy* ( vocab -- ) ".app deploy tool" assert.app "resource:" [ dup deploy-config [ diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index ee9c2b9fab..72e1c33a26 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -6,6 +6,7 @@ memory kernel.private continuations io prettyprint vocabs.loader debugger system strings ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes +QUALIFIED: command-line QUALIFIED: compiler.errors.private QUALIFIED: compiler.units QUALIFIED: continuations @@ -139,14 +140,17 @@ IN: tools.deploy.shaker { } { "cpu" } strip-vocab-globals % { + gensym classes:class-and-cache classes:class-not-cache classes:class-or-cache classes:class<-cache classes:classes-intersect-cache classes:update-map + command-line:main-vocab-hook compiled-crossref compiler.units:recompile-hook + compiler.units:update-tuples-hook definitions:crossref interactive-vocabs layouts:num-tags @@ -186,6 +190,11 @@ IN: tools.deploy.shaker deploy-ui? get [ "ui-error-hook" "ui.gadgets.worlds" lookup , ] when + + "" "inference.dataflow" lookup [ , ] when* + + "windows-messages" "windows.messages" lookup [ , ] when* + ] { } make ; : strip-globals ( stripped-globals -- ) diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 1c9a8195c5..33ab877ee1 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -25,11 +25,7 @@ IN: tools.deploy.windows : image-name ( vocab bundle-name -- str ) prepend-path ".image" append ; -TUPLE: windows-deploy-implementation ; - -T{ windows-deploy-implementation } deploy-implementation set-global - -M: windows-deploy-implementation deploy* +M: winnt deploy* "." resource-path [ dup deploy-config [ [ deploy-name get create-exe-dir ] keep diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 927f7111fa..5b835cd52f 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -27,7 +27,7 @@ M: method-spec make-disassemble-cmd first2 method make-disassemble-cmd ; : gdb-binary ( -- string ) - os "freebsd" = "gdb66" "gdb" ? ; + os freebsd? "gdb66" "gdb" ? ; : run-gdb ( -- lines ) diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index d548c0a4f5..4d1a4da6b1 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -3,7 +3,8 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words -sequences.private assocs models ; +sequences.private assocs models arrays accessors +generic generic.standard ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -51,9 +52,16 @@ DEFER: start-walker-thread : walk ( quot -- quot' ) \ break prefix [ break rethrow ] recover ; -: add-breakpoint ( quot -- quot' ) +GENERIC: add-breakpoint ( quot -- quot' ) + +M: callable add-breakpoint dup [ break ] head? [ \ break prefix ] unless ; +M: array add-breakpoint + [ add-breakpoint ] map ; + +M: object add-breakpoint ; + : (step-into-quot) ( quot -- ) add-breakpoint call ; : (step-into-if) ? (step-into-quot) ; @@ -61,20 +69,17 @@ DEFER: start-walker-thread : (step-into-dispatch) nth (step-into-quot) ; : (step-into-execute) ( word -- ) - dup "step-into" word-prop [ - call - ] [ - dup primitive? [ - execute break - ] [ - word-def (step-into-quot) - ] if - ] ?if ; + { + { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] } + { [ dup standard-generic? ] [ effective-method (step-into-execute) ] } + { [ dup primitive? ] [ execute break ] } + { [ t ] [ word-def (step-into-quot) ] } + } cond ; \ (step-into-execute) t "step-into?" set-word-prop : (step-into-continuation) - continuation callstack over set-continuation-call break ; + continuation callstack >>call break ; ! Messages sent to walker thread SYMBOL: step @@ -94,15 +99,18 @@ SYMBOL: +stopped+ : change-frame ( continuation quot -- continuation' ) #! Applies quot to innermost call frame of the #! continuation. - >r clone r> - over continuation-call clone - [ - dup innermost-frame-scan 1+ - swap innermost-frame-quot - rot call - ] keep - [ set-innermost-frame-quot ] keep - over set-continuation-call ; inline + >r clone r> [ + >r clone r> + [ + >r + [ innermost-frame-scan 1+ ] + [ innermost-frame-quot ] bi + r> call + ] + [ drop set-innermost-frame-quot ] + [ drop ] + 2tri + ] curry change-call ; inline : step-msg ( continuation -- continuation' ) [ @@ -143,6 +151,7 @@ SYMBOL: +stopped+ swap % unclip { { [ dup \ break eq? ] [ , ] } { [ dup quotation? ] [ add-breakpoint , \ break , ] } + { [ dup array? ] [ add-breakpoint , \ break , ] } { [ dup word? ] [ literalize , \ (step-into-execute) , ] } { [ t ] [ , \ break , ] } } cond % @@ -177,16 +186,17 @@ SYMBOL: +stopped+ { step-back [ f ] } { f [ +stopped+ set-status f ] } [ - dup walker-continuation tget set-model - step-into-msg + [ walker-continuation tget set-model ] + [ step-into-msg ] bi ] } case ] handle-synchronous ] [ ] while ; : step-back-msg ( continuation -- continuation' ) - walker-history tget dup pop* - empty? [ drop walker-history tget pop ] unless ; + walker-history tget + [ pop* ] + [ dup empty? [ drop ] [ nip pop ] if ] bi ; : walker-suspended ( continuation -- continuation' ) +suspended+ set-status diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 79b7041dcb..59adcf9af1 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -12,7 +12,7 @@ TUPLE: handle view window ; C: handle -TUPLE: cocoa-ui-backend ; +SINGLETON: cocoa-ui-backend SYMBOL: stop-after-last-window? @@ -119,6 +119,6 @@ M: cocoa-ui-backend ui ] ui-running ] with-cocoa ; -T{ cocoa-ui-backend } ui-backend set-global +cocoa-ui-backend ui-backend set-global [ running.app? "ui" "listener" ? ] main-vocab-hook set-global diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 1963f5670a..1c83bc9713 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -27,9 +27,8 @@ DEFER: freetype \ freetype get-global expired? [ init-freetype ] when \ freetype get-global ; -TUPLE: font ascent descent height handle widths ; - -M: font equal? 2drop f ; +TUPLE: font < identity-tuple +ascent descent height handle widths ; M: font hashcode* drop font hashcode* ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index ddcaa4b979..c4f11f2e87 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -44,14 +44,12 @@ M: array rect-dim drop { 0 0 } ; : rect-union ( rect1 rect2 -- newrect ) (rect-union) ; -TUPLE: gadget +TUPLE: gadget < identity-tuple pref-dim parent children orientation focus visible? root? clipped? layout-state graft-state graft-node interior boundary model ; -M: gadget equal? 2drop f ; - M: gadget hashcode* drop gadget hashcode* ; M: gadget model-changed 2drop ; @@ -354,7 +352,7 @@ SYMBOL: in-layout? swap [ over (add-gadget) ] each relayout ; : parents ( gadget -- seq ) - [ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ; + [ gadget-parent ] follow ; : each-parent ( gadget quot -- ? ) >r parents r> all? ; inline @@ -401,7 +399,7 @@ M: f request-focus-on 2drop ; dup focusable-child swap request-focus-on ; : focus-path ( world -- seq ) - [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ; + [ gadget-parent ] follow ; : make-gadget ( quot gadget -- gadget ) [ \ make-gadget rot with-variable ] keep ; inline diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor index e3f6e36050..0263b15d71 100755 --- a/extra/ui/gadgets/panes/panes-tests.factor +++ b/extra/ui/gadgets/panes/panes-tests.factor @@ -1,8 +1,8 @@ IN: ui.gadgets.panes.tests USING: alien ui.gadgets.panes ui.gadgets namespaces -kernel sequences io io.streams.string tools.test prettyprint -definitions help help.syntax help.markup splitting -tools.test.ui models ; +kernel sequences io io.styles io.streams.string tools.test +prettyprint definitions help help.syntax help.markup +help.stylesheet splitting tools.test.ui models math inspector ; : #children "pane" get gadget-children length ; @@ -17,20 +17,79 @@ tools.test.ui models ; [ t ] [ #children "num-children" get = ] unit-test : test-gadget-text - dup make-pane gadget-text - swap with-string-writer "\n" ?tail drop "\n" ?tail drop = ; + dup make-pane gadget-text dup print "======" print + swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ; [ t ] [ [ "hello" write ] test-gadget-text ] unit-test [ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test +[ t ] [ + [ + H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting + ] test-gadget-text +] unit-test +[ t ] [ + [ + H{ { wrap-margin 100 } } [ + H{ } [ + "hello" pprint + ] with-style + ] with-nesting + ] test-gadget-text +] unit-test [ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test +[ t ] [ [ \ + describe ] test-gadget-text ] unit-test [ t ] [ [ \ = see ] test-gadget-text ] unit-test [ t ] [ [ \ = help ] test-gadget-text ] unit-test -ARTICLE: "test-article" "This is a test article" +[ t ] [ + [ + title-style get [ + "Hello world" write + ] with-style + ] test-gadget-text +] unit-test + + +[ t ] [ + [ + title-style get [ + "Hello world" write + ] with-nesting + ] test-gadget-text +] unit-test + +[ t ] [ + [ + title-style get [ + title-style get [ + "Hello world" write + ] with-nesting + ] with-style + ] test-gadget-text +] unit-test + +[ t ] [ + [ + title-style get [ + title-style get [ + [ "Hello world" write ] ($block) + ] with-nesting + ] with-style + ] test-gadget-text +] unit-test + +ARTICLE: "test-article-1" "This is a test article" +"Hello world, how are you today." ; + +[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test + +[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test + +ARTICLE: "test-article-2" "This is a test article" "Hello world, how are you today." { $table { "a" "b" } { "c" "d" } } ; -[ t ] [ [ "test-article" help ] test-gadget-text ] unit-test +[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test [ \ = see ] with-pane [ \ = help ] with-pane diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 91b7f0f225..fedacbd2af 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -166,7 +166,7 @@ M: pane-stream dispose drop ; M: pane-stream stream-flush drop ; M: pane-stream make-span-stream - ; + swap ; ! Character styles diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor index a44b553858..8ee64b58be 100755 --- a/extra/ui/gadgets/worlds/worlds.factor +++ b/extra/ui/gadgets/worlds/worlds.factor @@ -5,7 +5,7 @@ namespaces opengl sequences io combinators math.vectors ui.gadgets ui.gestures ui.render ui.backend inspector ; IN: ui.gadgets.worlds -TUPLE: world +TUPLE: world < identity-tuple active? focused? glass title status @@ -46,8 +46,6 @@ M: world request-focus-on ( child gadget -- ) t over set-gadget-root? dup request-focus ; -M: world equal? 2drop f ; - M: world hashcode* drop world hashcode* ; M: world pref-dim* diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index eca5740bbc..522c26e92e 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -49,7 +49,7 @@ TUPLE: deploy-gadget vocab settings ; [ bundle-name deploy-ui - macosx? [ exit-when-windows-closed ] when + os macosx? [ exit-when-windows-closed ] when io-settings reflection-settings advanced-settings diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 06fc3c87a0..c760867d71 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -6,7 +6,8 @@ math.vectors models namespaces parser prettyprint quotations sequences sequences.lib strings threads listener classes.tuple ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds ui.gestures -definitions boxes calendar concurrency.flags ui.tools.workspace ; +definitions boxes calendar concurrency.flags ui.tools.workspace +accessors ; IN: ui.tools.interactor TUPLE: interactor history output flag thread help ; @@ -123,12 +124,12 @@ M: interactor stream-read-partial stream-read ; : go-to-error ( interactor error -- ) - dup parse-error-line 1- swap parse-error-col 2array + [ line>> 1- ] [ column>> ] bi 2array over set-caret mark>caret ; : handle-parse-error ( interactor error -- ) - dup parse-error? [ 2dup go-to-error delegate ] when + dup parse-error? [ 2dup go-to-error error>> ] when swap find-workspace debugger-popup ; : try-parse ( lines interactor -- quot/error/f ) diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 7db0d63f45..52c3d2de42 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: inspector ui.tools.interactor ui.tools.inspector ui.tools.workspace help.markup io io.streams.duplex io.styles @@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words prettyprint listener debugger threads boxes concurrency.flags -math arrays ; +math arrays generic accessors ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -101,16 +101,26 @@ M: listener-operation invoke-command ( target command -- ) : clear-stack ( listener -- ) [ clear ] swap (call-listener) ; -: word-completion-string ( word listener -- string ) - >r dup word-name swap word-vocabulary dup vocab-words r> - listener-gadget-input interactor-use memq? +GENERIC# word-completion-string 1 ( word listener -- string ) + +M: method-body word-completion-string + >r "method-generic" word-prop r> word-completion-string ; + +USE: generic.standard.engines.tuple + +M: tuple-dispatch-engine-word word-completion-string + >r "engine-generic" word-prop r> word-completion-string ; + +M: word word-completion-string ( word listener -- string ) + >r [ word-name ] [ word-vocabulary ] bi dup vocab-words r> + input>> interactor-use memq? [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ; : insert-word ( word -- ) get-workspace workspace-listener [ word-completion-string ] keep - listener-gadget-input user-input ; + input>> user-input ; : quot-action ( interactor -- lines ) dup control-value diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index f47a82275b..e0c9f24122 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -10,7 +10,7 @@ shuffle opengl ui.render unicode.case ascii math.bitfields locals symbols ; IN: ui.windows -TUPLE: windows-ui-backend ; +SINGLETON: windows-ui-backend : crlf>lf CHAR: \r swap remove ; : lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ; @@ -496,6 +496,6 @@ M: windows-ui-backend ui ] [ cleanup-win32-ui ] [ ] cleanup ] ui-running ; -T{ windows-ui-backend } ui-backend set-global +windows-ui-backend ui-backend set-global [ "ui" ] main-vocab-hook set-global diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index eaf87acace..9445486656 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -8,7 +8,7 @@ io.encodings.utf8 combinators debugger system command-line ui.render math.vectors classes.tuple opengl.gl threads ; IN: ui.x11 -TUPLE: x11-ui-backend ; +SINGLETON: x11-ui-backend : XA_NET_WM_NAME "_NET_WM_NAME" x-atom ; @@ -259,7 +259,7 @@ M: x11-ui-backend ui ( -- ) ] with-x ] ui-running ; -T{ x11-ui-backend } ui-backend set-global +x11-ui-backend ui-backend set-global [ "DISPLAY" os-env "ui" "listener" ? ] main-vocab-hook set-global diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor index 6cb5d6385b..d80db44348 100755 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -73,8 +73,8 @@ C-STRUCT: sockaddr-un : SEEK_END 2 ; inline os { - { "macosx" [ "unix.bsd.macosx" require ] } - { "freebsd" [ "unix.bsd.freebsd" require ] } - { "openbsd" [ "unix.bsd.openbsd" require ] } - { "netbsd" [ "unix.bsd.netbsd" require ] } + { macosx [ "unix.bsd.macosx" require ] } + { freebsd [ "unix.bsd.freebsd" require ] } + { openbsd [ "unix.bsd.openbsd" require ] } + { netbsd [ "unix.bsd.netbsd" require ] } } case diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor index 55b53bd6d0..080820ebd0 100644 --- a/extra/unix/kqueue/kqueue.factor +++ b/extra/unix/kqueue/kqueue.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system sequences vocabs.loader ; +USING: alien.syntax system sequences vocabs.loader words ; IN: unix.kqueue -<< "unix.kqueue." os append require >> +<< "unix.kqueue." os word-name append require >> FUNCTION: int kqueue ( ) ; diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor index f7432332b9..342047d9af 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -60,11 +60,11 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; << os { - { "linux" [ "unix.stat.linux" require ] } - { "macosx" [ "unix.stat.macosx" require ] } - { "freebsd" [ "unix.stat.freebsd" require ] } - { "netbsd" [ "unix.stat.netbsd" require ] } - { "openbsd" [ "unix.stat.openbsd" require ] } + { linux [ "unix.stat.linux" require ] } + { macosx [ "unix.stat.macosx" require ] } + { freebsd [ "unix.stat.freebsd" require ] } + { netbsd [ "unix.stat.netbsd" require ] } + { openbsd [ "unix.stat.openbsd" require ] } } case >> diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor index 983d5d677d..0ac2fa608e 100644 --- a/extra/unix/types/types.factor +++ b/extra/unix/types/types.factor @@ -1,17 +1,14 @@ - -USING: kernel system alien.syntax combinators vocabs.loader ; - +USING: kernel system alien.syntax combinators vocabs.loader +system ; IN: unix.types TYPEDEF: void* caddr_t -os - { - { "linux" [ "unix.types.linux" require ] } - { "macosx" [ "unix.types.macosx" require ] } - { "freebsd" [ "unix.types.freebsd" require ] } - { "openbsd" [ "unix.types.openbsd" require ] } - { "netbsd" [ "unix.types.netbsd" require ] } - { "winnt" [ ] } - } -case +os { + { linux [ "unix.types.linux" require ] } + { macosx [ "unix.types.macosx" require ] } + { freebsd [ "unix.types.freebsd" require ] } + { openbsd [ "unix.types.openbsd" require ] } + { netbsd [ "unix.types.netbsd" require ] } + { winnt [ ] } +} case diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index ffd102901c..e911a5c039 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -161,8 +161,8 @@ FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { - { [ linux? ] [ "unix.linux" require ] } - { [ bsd? ] [ "unix.bsd" require ] } - { [ solaris? ] [ "unix.solaris" require ] } + { [ os linux? ] [ "unix.linux" require ] } + { [ os bsd? ] [ "unix.bsd" require ] } + { [ os solaris? ] [ "unix.solaris" require ] } } cond diff --git a/license.txt b/license.txt index 87f170da8c..768c13c549 100644 --- a/license.txt +++ b/license.txt @@ -1,24 +1,22 @@ -/* - * Copyright (C) 2003, 2007 Slava Pestov and friends. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * 1. Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; - * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR - * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF - * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - */ +Copyright (C) 2003, 2008 Slava Pestov and friends. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/vm/data_gc.c b/vm/data_gc.c index 0a1fad575a..24f7cfecb9 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -730,7 +730,6 @@ void garbage_collection(CELL gen, /* collect objects referenced from stacks and environment */ collect_roots(); - /* collect objects referenced from older generations */ collect_cards(); diff --git a/vm/debug.c b/vm/debug.c index 7e18738afc..101313a5ee 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -146,6 +146,18 @@ void print_objects(CELL start, CELL end) } } +void print_datastack(void) +{ + printf("==== DATA STACK:\n"); + print_objects(ds_bot,ds); +} + +void print_retainstack(void) +{ + printf("==== RETAIN STACK:\n"); + print_objects(rs_bot,rs); +} + void print_stack_frame(F_STACK_FRAME *frame) { print_obj(frame_executing(frame)); @@ -158,6 +170,7 @@ void print_stack_frame(F_STACK_FRAME *frame) void print_callstack(void) { + printf("==== CALL STACK:\n"); CELL bottom = (CELL)stack_chain->callstack_bottom; CELL top = (CELL)stack_chain->callstack_top; iterate_callstack(top,bottom,print_stack_frame); @@ -336,6 +349,8 @@ void factorbug(void) printf("push -- push object on data stack - NOT SAFE\n"); printf("code -- code heap dump\n"); + bool seen_command = false; + for(;;) { char cmd[1024]; @@ -344,7 +359,22 @@ void factorbug(void) fflush(stdout); if(scanf("%1000s",cmd) <= 0) + { + if(!seen_command) + { + /* If we exit with an EOF immediately, then + dump stacks. This is useful for builder and + other cases where Factor is run with stdin + redirected to /dev/null */ + print_datastack(); + print_retainstack(); + print_callstack(); + } + exit(1); + } + + seen_command = true; if(strcmp(cmd,"d") == 0) { @@ -371,9 +401,9 @@ void factorbug(void) else if(strcmp(cmd,"r") == 0) dump_memory(rs_bot,rs); else if(strcmp(cmd,".s") == 0) - print_objects(ds_bot,ds); + print_datastack(); else if(strcmp(cmd,".r") == 0) - print_objects(rs_bot,rs); + print_retainstack(); else if(strcmp(cmd,".c") == 0) print_callstack(); else if(strcmp(cmd,"e") == 0) diff --git a/vm/factor.c b/vm/factor.c index 20667a23f5..5825f97bdd 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -36,22 +36,36 @@ void do_stage1_init(void) fprintf(stderr,"*** Stage 2 early init... "); fflush(stderr); + GROWABLE_ARRAY(words); + begin_scan(); CELL obj; while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) - { - F_WORD *word = untag_object(obj); - default_word_code(word,false); - update_word_xt(word); - } + GROWABLE_ADD(words,obj); } /* End heap scan */ gc_off = false; + GROWABLE_TRIM(words); + REGISTER_ROOT(words); + + CELL i; + CELL length = array_capacity(untag_object(words)); + for(i = 0; i < length; i++) + { + F_WORD *word = untag_word(array_nth(untag_array(words),i)); + REGISTER_UNTAGGED(word); + default_word_code(word,false); + UNREGISTER_UNTAGGED(word); + update_word_xt(word); + } + + UNREGISTER_ROOT(words); + iterate_code_heap(relocate_code_block); userenv[STAGE2_ENV] = T; diff --git a/vm/primitives.c b/vm/primitives.c index 203ebb7f6b..6a6aeb9d46 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -106,7 +106,6 @@ void *primitives[] = { primitive_code_room, primitive_os_env, primitive_millis, - primitive_type, primitive_tag, primitive_modify_code_heap, primitive_dlopen, @@ -178,7 +177,6 @@ void *primitives[] = { primitive_sleep, primitive_float_array, primitive_tuple_boa, - primitive_class_hash, primitive_callstack_to_array, primitive_innermost_stack_frame_quot, primitive_innermost_stack_frame_scan, diff --git a/vm/run.c b/vm/run.c index d03d999ffd..282be0a447 100755 --- a/vm/run.c +++ b/vm/run.c @@ -22,8 +22,11 @@ void fix_stacks(void) be stored in registers, so callbacks must save and restore the correct values */ void save_stacks(void) { - stack_chain->datastack = ds; - stack_chain->retainstack = rs; + if(stack_chain) + { + stack_chain->datastack = ds; + stack_chain->retainstack = rs; + } } /* called on entry into a compiled callback */ @@ -304,32 +307,11 @@ DEFINE_PRIMITIVE(sleep) sleep_millis(to_cell(dpop())); } -DEFINE_PRIMITIVE(type) -{ - drepl(tag_fixnum(type_of(dpeek()))); -} - DEFINE_PRIMITIVE(tag) { drepl(tag_fixnum(TAG(dpeek()))); } -DEFINE_PRIMITIVE(class_hash) -{ - CELL obj = dpeek(); - CELL tag = TAG(obj); - if(tag == TUPLE_TYPE) - { - F_TUPLE *tuple = untag_object(obj); - F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); - drepl(layout->hashcode); - } - else if(tag == OBJECT_TYPE) - drepl(get(UNTAG(obj))); - else - drepl(tag_fixnum(tag)); -} - DEFINE_PRIMITIVE(slot) { F_FIXNUM slot = untag_fixnum_fast(dpop()); diff --git a/vm/run.h b/vm/run.h index 216a00b27d..c112c5f587 100755 --- a/vm/run.h +++ b/vm/run.h @@ -253,9 +253,7 @@ DECLARE_PRIMITIVE(set_os_envs); DECLARE_PRIMITIVE(eq); DECLARE_PRIMITIVE(millis); DECLARE_PRIMITIVE(sleep); -DECLARE_PRIMITIVE(type); DECLARE_PRIMITIVE(tag); -DECLARE_PRIMITIVE(class_hash); DECLARE_PRIMITIVE(slot); DECLARE_PRIMITIVE(set_slot); diff --git a/vm/types.c b/vm/types.c index 24bb4cb3ca..f88c3ef3cb 100755 --- a/vm/types.c +++ b/vm/types.c @@ -42,7 +42,7 @@ F_WORD *allot_word(CELL vocab, CELL name) UNREGISTER_ROOT(name); UNREGISTER_ROOT(vocab); - word->hashcode = tag_fixnum(rand()); + word->hashcode = tag_fixnum((rand() << 16) ^ rand()); word->vocabulary = vocab; word->name = name; word->def = userenv[UNDEFINED_ENV];