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..56be3e66a5 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 ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index d874243d71..ca1a89b4ae 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -45,7 +45,7 @@ GENERIC: c-type ( name -- type ) foldable : parse-array-type ( name -- array ) "[" split unclip - >r [ "]" ?tail drop string>number ] map r> add* ; + >r [ "]" ?tail drop string>number ] map r> prefix ; M: string c-type ( name -- type ) CHAR: ] over member? [ @@ -162,7 +162,7 @@ DEFER: >c-ushort-array >r >c-ushort-array r> byte-array>memory ; : (define-nth) ( word type quot -- ) - >r heap-size [ rot * ] swap add* r> append define-inline ; + >r heap-size [ rot * ] swap prefix r> append define-inline ; : nth-word ( name vocab -- word ) >r "-nth" append r> create ; @@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- ) f swap box-parameter ; : define-deref ( name vocab -- ) - >r dup CHAR: * add* r> create - swap c-getter 0 add* define-inline ; + >r dup CHAR: * prefix r> create + swap c-getter 0 prefix define-inline ; : define-out ( name vocab -- ) over [ tuck 0 ] over c-setter append swap - >r >r constructor-word r> r> add* define-inline ; + >r >r constructor-word r> r> prefix define-inline ; : c-bool> ( int -- ? ) zero? not ; @@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- ) #! staging violations dup array? [ unclip >r [ dup word? [ word-def call ] when ] map - r> add* + r> prefix ] when ; : malloc-file-contents ( path -- alien len ) @@ -388,6 +388,6 @@ M: long-long-type box-return ( 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 3e0062c85a..1a9d5b5392 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -18,7 +18,7 @@ IN: alien.compiler : alien-node-parameters* ( node -- seq ) dup parameters>> - swap return>> large-struct? [ "void*" add* ] when ; + swap return>> large-struct? [ "void*" prefix ] when ; : alien-node-return* ( node -- ctype ) return>> dup large-struct? [ drop "void" ] when ; diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index 6c7775de2b..e7e576293f 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -8,7 +8,7 @@ kernel words slots assocs namespaces ; dup ?word-name swap 2array over slot-spec-name rot slot-spec-type 2array 2array - [ { $instance } swap add ] assoc-map ; + [ { $instance } swap suffix ] assoc-map ; : $spec-reader-values ( slot-spec class -- ) ($spec-reader-values) $values ; @@ -16,9 +16,9 @@ kernel words slots assocs namespaces ; : $spec-reader-description ( slot-spec class -- ) [ "Outputs the value stored in the " , - { $snippet } rot slot-spec-name add , + { $snippet } rot slot-spec-name suffix , " slot of " , - { $instance } swap add , + { $instance } swap suffix , " instance." , ] { } make $description ; @@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ; : $spec-writer-description ( slot-spec class -- ) [ "Stores a new value to the " , - { $snippet } rot slot-spec-name add , + { $snippet } rot slot-spec-name suffix , " slot of " , - { $instance } swap add , + { $instance } swap suffix , " instance." , ] { } make $description ; diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index e5de8ab83e..491f4351a3 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -16,7 +16,7 @@ IN: alien.structs ] reduce ; : define-struct-slot-word ( spec word quot -- ) - rot slot-spec-offset add* define-inline ; + rot slot-spec-offset prefix define-inline ; : define-getter ( type spec -- ) [ set-reader-props ] keep 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..6b467caa5a 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 diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 5d49203554..6e0f8e2970 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -12,7 +12,8 @@ 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 ; @@ -305,7 +306,7 @@ M: float-array ' float-array emit-dummy-array ; ! Tuples : (emit-tuple) ( tuple -- pointer ) [ tuple>array 1 tail-slice ] - [ class transfer-word tuple-layout ] bi add* [ ' ] map + [ class transfer-word tuple-layout ] bi prefix [ ' ] map tuple type-number dup [ emit-seq ] emit-object ; : emit-tuple ( tuple -- pointer ) 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..6c87730278 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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..0f468908a9 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 ; @@ -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 2945bd2546..97309dbea2 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel classes combinators accessors sequences arrays vectors assocs namespaces words sorting layouts math hashtables -; +kernel.private ; IN: classes.algebra : 2cache ( key1 key2 assoc quot -- value ) @@ -138,10 +138,10 @@ C: anonymous-complement members>> [ class-and ] with map ; : left-anonymous-intersection-and ( first second -- class ) - >r members>> r> add ; + >r members>> r> suffix ; : right-anonymous-intersection-and ( first second -- class ) - members>> swap add ; + members>> swap suffix ; : (class-and) ( first second -- class ) { @@ -158,10 +158,10 @@ C: anonymous-complement } cond ; : left-anonymous-union-or ( first second -- class ) - >r members>> r> add ; + >r members>> r> suffix ; : right-anonymous-union-or ( first second -- class ) - members>> swap add ; + members>> swap suffix ; : (class-or) ( first second -- class ) { @@ -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/classes-docs.factor b/core/classes/classes-docs.factor index 9573de8949..3f30b71457 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -21,7 +21,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 } @@ -47,6 +46,7 @@ $nl "Other sorts of classes:" { $subsection "builtin-classes" } { $subsection "unions" } +{ $subsection "singletons" } { $subsection "mixins" } { $subsection "predicates" } "Classes can be inspected and operated upon:" 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 435c7413a3..c45fd7360b 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -25,9 +25,11 @@ 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 + +PREDICATE: class < word + "class" word-prop ; + SYMBOL: builtins PREDICATE: builtin-class < class @@ -58,7 +60,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 +74,7 @@ M: word reset-class drop ; ! update-map : class-uses ( class -- seq ) - dup members swap superclass [ add ] when* ; + [ members ] [ superclass ] bi [ suffix ] when* ; : class-usages ( class -- assoc ) [ update-map get at ] closure ; @@ -83,7 +85,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 +94,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 +111,28 @@ 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 ; +M: hi-tag class hi-tag type>class ; + +M: object class tag type>class ; + +: instance? ( obj class -- ? ) + "predicate" word-prop call ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index eb6b3bd6e2..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 @@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ; swap redefine-mixin-class ; inline : add-mixin-instance ( class mixin -- ) - [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ; + [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ; : remove-mixin-instance ( class mixin -- ) [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ; 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/singleton/authors.txt b/core/classes/singleton/authors.txt similarity index 100% rename from extra/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..8548f84a3a --- /dev/null +++ b/core/classes/singleton/singleton-docs.factor @@ -0,0 +1,28 @@ +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. Methods may dispatch off of singleton classes." +{ $subsection POSTPONE: SINGLETON: } +{ $subsection define-singleton-class } ; + +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: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } +} { $see-also + POSTPONE: PREDICATE: +} ; + +HELP: define-singleton-class +{ $values { "word" "a new word" } } +{ $description + "Defines a newly created word to be a singleton class." } ; + +{ POSTPONE: SINGLETON: define-singleton-class } related-words + +ABOUT: "singletons" diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor new file mode 100644 index 0000000000..2ed51abb93 --- /dev/null +++ b/core/classes/singleton/singleton-tests.factor @@ -0,0 +1,12 @@ +USING: kernel classes.singleton tools.test prettyprint io.streams.string ; +IN: classes.singleton.tests + +[ ] [ SINGLETON: bzzt ] unit-test +[ t ] [ bzzt bzzt? ] unit-test +[ t ] [ bzzt bzzt eq? ] unit-test +GENERIC: zammo ( obj -- str ) +[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test +[ "yes!" ] [ bzzt zammo ] unit-test +[ ] [ SINGLETON: omg ] 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..664f0545fa 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -153,14 +153,6 @@ HELP: tuple= { $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 diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index db0e25f091..a8e9066f56 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -62,13 +62,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 @@ -394,7 +394,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 +511,45 @@ USE: vocabs define-tuple-class ] with-compilation-unit ] unit-test + +[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] 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 a3d0238d1c..b1cb3f8a66 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -19,7 +19,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 +40,9 @@ PRIVATE> [ drop ] [ no-tuple-class ] if ; : tuple>array ( tuple -- array ) - prepare-tuple>array >r copy-tuple-slots r> layout-class add* ; + prepare-tuple>array + >r copy-tuple-slots r> + layout-class prefix ; : tuple-slots ( tuple -- array ) prepare-tuple>array drop copy-tuple-slots ; @@ -120,17 +122,8 @@ 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 add* ; + superclasses [ slot-names ] map concat \ class prefix ; : compute-slot-permutation ( class old-slot-names -- permutation ) >r all-slot-names r> [ index ] curry map ; @@ -161,25 +154,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 +182,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 +204,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 +233,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.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 e19847dbd4..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 ; @@ -43,7 +49,7 @@ ERROR: no-case ; : with-datastack ( stack quot -- newstack ) datastack >r >r >array set-datastack r> call - datastack r> swap add set-datastack 2nip ; inline + datastack r> swap suffix set-datastack 2nip ; inline : recursive-hashcode ( n obj quot -- code ) pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline @@ -66,7 +72,7 @@ M: hashtable hashcode* reverse [ no-cond ] swap alist>quot ; : linear-case-quot ( default assoc -- quot ) - [ >r [ dupd = ] curry r> \ drop add* ] assoc-map + [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map alist>quot ; : (distribute-buckets) ( buckets pair keys -- ) 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.factor b/core/compiler/tests/templates.factor index 081a8fd47c..565c045e2a 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 diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 8d1e1f281f..4670cf86d2 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -5,8 +5,6 @@ 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 ; @@ -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..a1a4bd3809 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,25 +122,25 @@ 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 ; @@ -166,19 +164,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 +186,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 +195,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 +203,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 +213,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 +228,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 +238,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 +262,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 +270,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 7aa78ce52e..d092473960 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics } define-intrinsics : fixnum-register-op ( op -- pair ) - [ "out" operand "y" operand "x" operand ] swap add H{ + [ "out" operand "y" operand "x" operand ] swap suffix H{ { +input+ { { f "x" } { f "y" } } } { +scratch+ { { f "out" } } } { +output+ { "out" } } } 2array ; : fixnum-value-op ( op -- pair ) - [ "out" operand "x" operand "y" operand ] swap add H{ + [ "out" operand "x" operand "y" operand ] swap suffix H{ { +input+ { { f "x" } { [ small-tagged? ] "y" } } } { +scratch+ { { f "out" } } } { +output+ { "out" } } @@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics } define-intrinsic : fixnum-register-jump ( op -- pair ) - [ "x" operand 0 "y" operand CMP ] swap add + [ "x" operand 0 "y" operand CMP ] swap suffix { { f "x" } { f "y" } } 2array ; : fixnum-value-jump ( op -- pair ) - [ 0 "x" operand "y" operand CMPI ] swap add + [ 0 "x" operand "y" operand CMPI ] swap suffix { { f "x" } { [ small-tagged? ] "y" } } 2array ; : define-fixnum-jump ( word op -- ) @@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics } define-intrinsic : define-float-op ( word op -- ) - [ "z" operand "x" operand "y" operand ] swap add H{ + [ "z" operand "x" operand "y" operand ] swap suffix H{ { +input+ { { float "x" } { float "y" } } } { +scratch+ { { float "z" } } } { +output+ { "z" } } @@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics ] each : define-float-jump ( word op -- ) - [ "x" operand 0 "y" operand FCMPU ] swap add + [ "x" operand 0 "y" operand FCMPU ] swap suffix { { float "x" } { float "y" } } define-if-intrinsic ; { @@ -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..4d447b38fc 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 ; @@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- ) 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..d3ccffe00e 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 -- ) +M: x86.64 %unbox-long-long ( n func -- ) T{ 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 -- ) +M: x86.64 %box-long-long ( n func -- ) T{ 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,8 +168,6 @@ 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 >> 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..6c9a4dc05f 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -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 [+] ; @@ -33,34 +31,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 +68,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 +81,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 +103,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 +141,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/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 796388ffe1..a3ab256ea1 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -230,7 +230,7 @@ UNION: operand register indirect ; : opcode-or ( opcode mask -- opcode' ) swap dup array? - [ 1 cut* first rot bitor add ] [ bitor ] if ; + [ 1 cut* first rot bitor suffix ] [ bitor ] if ; : 1-operand ( op reg rex.w opcode -- ) #! The 'reg' is not really a register, but a value for the diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index f5409a24f5..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 @@ -156,7 +104,7 @@ IN: cpu.x86.intrinsics ! Fixnums : fixnum-op ( op hash -- pair ) - >r [ "x" operand "y" operand ] swap add r> 2array ; + >r [ "x" operand "y" operand ] swap suffix r> 2array ; : fixnum-value-op ( op -- pair ) H{ @@ -251,7 +199,7 @@ IN: cpu.x86.intrinsics \ fixnum- \ SUB overflow-template : fixnum-jump ( op inputs -- pair ) - >r [ "x" operand "y" operand CMP ] swap add r> 2array ; + >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ; : fixnum-value-jump ( op -- pair ) { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ; diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor index 98e42fa7fe..9c477b4132 100755 --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -8,7 +8,7 @@ math.floats.private layouts quotations ; IN: cpu.x86.sse2 : define-float-op ( word op -- ) - [ "x" operand "y" operand ] swap add H{ + [ "x" operand "y" operand ] swap suffix H{ { +input+ { { float "x" } { float "y" } } } { +output+ { "x" } } } define-intrinsic ; @@ -23,7 +23,7 @@ IN: cpu.x86.sse2 ] each : define-float-jump ( word op -- ) - [ "x" operand "y" operand UCOMISD ] swap add + [ "x" operand "y" operand UCOMISD ] swap suffix { { float "x" } { float "y" } } define-if-intrinsic ; { 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/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/generic/generic-docs.factor b/core/generic/generic-docs.factor index 56de801e7a..04252b6b3b 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -37,7 +37,6 @@ $nl { $subsection create-method } "Method definitions can be looked up:" { $subsection method } -{ $subsection methods } "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,15 +62,6 @@ 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: "generic" "Generic words and methods" @@ -129,10 +119,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 +146,4 @@ 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 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 131b7e57c9..72948c5473 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,17 @@ 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 ; +: 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 +61,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 +106,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 +114,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 +135,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 +157,15 @@ M: assoc update-methods ( assoc -- ) ] if ; M: generic subwords - dup "methods" word-prop values - swap "default-method" word-prop add ; + [ + [ "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..46208744f0 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -12,9 +12,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 +71,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-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 4447c5a264..c36e5f1921 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -3,194 +3,164 @@ 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 # ; - -C: standard-combination - -SYMBOL: (dispatch#) - -: (picker) ( n -- quot ) - { - { 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 - -: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ; - -ERROR: no-method object generic ; - -: error-method ( word -- quot ) - picker swap [ no-method ] curry append ; - -: empty-method ( word -- quot ) - [ - picker % [ delegate dup ] % - unpicker over add , - error-method \ drop add* , \ 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 ) - [ - picker % - \ tag , - group-methods build-type-vtable , - \ dispatch , - ] [ ] make ; - -: flatten-method ( class body -- ) - over members pick object bootstrap-word eq? not and [ - >r members r> [ flatten-method ] curry each - ] [ - swap set - ] if ; - -: flatten-methods ( methods -- newmethods ) - [ [ flatten-method ] assoc-each ] V{ } make-assoc ; - -: dispatched-types ( methods -- seq ) - keys object bootstrap-word swap remove prune ; - -: single-combination ( methods -- quot ) - dup length 4 <= [ - small-generic - ] [ - flatten-methods - dup dispatched-types [ number class< ] all? - [ tag-generic ] [ big-generic ] if - ] if ; - -: standard-methods ( word -- alist ) - dup methods swap default-method add* - [ 1quotation ] assoc-map ; - -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 - [ - standard-methods - [ [ drop ] prepend ] assoc-map - single-combination - ] with-hook ; - -: define-simple-generic ( word -- ) - T{ standard-combination f 0 } define-generic ; - -PREDICATE: standard-generic < generic - "combination" word-prop standard-combination? ; - -PREDICATE: simple-generic < standard-generic - "combination" word-prop standard-combination-# zero? ; - -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-# ; +: unpickers + { + [ 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 ) + picker swap [ no-method ] curry append ; + +: empty-method ( word -- quot ) + [ + picker % [ delegate dup ] % + unpicker over suffix , + error-method \ drop prefix , \ if , + ] [ ] make ; + +: default-method ( word -- pair ) + "default-method" word-prop + object bootstrap-word swap 2array ; + +: push-method ( method specializer atomic assoc -- ) + [ + [ H{ } clone ] unless* + [ methods>> set-at ] keep + ] change-at ; + +: flatten-method ( class method assoc -- ) + >r >r dup flatten-class keys swap r> r> [ + >r spin r> push-method + ] 3curry each ; + +: flatten-methods ( assoc -- assoc' ) + H{ } clone [ + [ + flatten-method + ] curry assoc-each + ] keep ; + +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; + +: find-default ( methods -- quot ) + #! Side-effects methods. + object bootstrap-word swap delete-at* [ + drop generic get "default-method" word-prop 1quotation + ] unless ; + +GENERIC: mangle-method ( method generic -- quot ) + +: single-combination ( word -- quot ) + [ + 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 ; + +TUPLE: standard-combination # ; + +C: standard-combination + +PREDICATE: standard-generic < generic + "combination" word-prop standard-combination? ; + +PREDICATE: simple-generic < standard-generic + "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# #>> ; + +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? ; + +: 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/inference/backend/backend.factor b/core/inference/backend/backend.factor index 2a2e6995eb..61412ccf9f 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 ; 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 @@ -92,7 +101,7 @@ M: wrapper apply-object r> recursive-state set ; : infer-quot-recursive ( quot word label -- ) - recursive-state get -rot 2array add* infer-quot ; + recursive-state get -rot 2array prefix infer-quot ; : time-bomb ( error -- ) [ throw ] curry recursive-state get infer-quot ; @@ -109,7 +118,7 @@ TUPLE: recursive-quotation-error quot ; dup value-literal callable? [ dup value-literal over value-recursion - rot f 2array add* infer-quot + rot f 2array prefix infer-quot ] [ drop bad-call ] if @@ -430,7 +439,7 @@ M: #call-label collect-recursion* [ [ swap collect-recursion* ] curry each-node ] { } make ; : join-values ( node -- ) - collect-recursion [ node-in-d ] map meta-d get add + collect-recursion [ node-in-d ] map meta-d get suffix unify-lengths unify-stacks meta-d [ length tail* ] change ; 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 ed36ca4890..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 add - 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 0b6cf04028..01c0a9c5f4 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -9,15 +9,13 @@ IN: inference.dataflow : \ 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,13 +28,12 @@ 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 -- ) @@ -205,7 +202,7 @@ UNION: #branch #if #dispatch ; 2dup 2slip rot [ 2drop t ] [ - >r dup node-children swap node-successor add r> + >r dup node-children swap node-successor suffix r> [ node-exists? ] curry contains? ] if ] [ 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 200208c6a5..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 @@ -56,7 +58,7 @@ M: pair (bitfield-quot) ( spec -- quot ) [ shift bitor ] append 2curry ; : bitfield-quot ( spec -- quot ) - [ (bitfield-quot) ] map [ 0 ] add* concat ; + [ (bitfield-quot) ] map [ 0 ] prefix concat ; \ bitfield [ bitfield-quot ] 1 define-transform @@ -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/backend/backend-tests.factor b/core/io/backend/backend-tests.factor old mode 100644 new mode 100755 index 04f34068eb..c3d7e8e89b --- a/core/io/backend/backend-tests.factor +++ b/core/io/backend/backend-tests.factor @@ -1,4 +1,4 @@ -IN: io.backend.tests -USING: tools.test io.backend kernel ; - -[ ] [ "a" normalize-pathname drop ] unit-test +IN: io.backend.tests +USING: tools.test io.backend kernel ; + +[ ] [ "a" normalize-path drop ] unit-test diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 6bcd448385..44b1eea349 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init kernel system namespaces io io.encodings -io.encodings.utf8 init assocs ; +io.encodings.utf8 init assocs splitting ; IN: io.backend SYMBOL: io-backend @@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- ) HOOK: normalize-directory io-backend ( str -- newstr ) -HOOK: normalize-pathname io-backend ( str -- newstr ) +HOOK: normalize-path io-backend ( str -- newstr ) -M: object normalize-directory normalize-pathname ; +M: object normalize-directory normalize-path ; : set-io-backend ( io-backend -- ) io-backend set-global init-io init-stdio diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 2ef26096e0..398fb6a068 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -59,7 +59,7 @@ M: tuple f decoder construct-boa ; over decoder-cr [ over cr- "\n" ?head [ - over stream-read1 [ add ] when* + over stream-read1 [ suffix ] when* ] when ] when nip ; diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 1953569223..342967acfc 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -252,7 +252,7 @@ HELP: normalize-directory { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ; -HELP: normalize-pathname +HELP: normalize-path { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 9920d8d25c..b4a7d44433 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -220,8 +220,6 @@ io.encodings.utf8 ; [ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test [ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test -[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test -[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test [ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test [ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test [ "/lib" ] [ "/usr" "../lib" append-path ] unit-test @@ -239,9 +237,6 @@ io.encodings.utf8 ; [ "lib" ] [ "" "lib" append-path ] unit-test [ "lib" ] [ "" "./lib" append-path ] unit-test -[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test -[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test - [ "foo/bar/." parent-directory ] must-fail [ "foo/bar/./" parent-directory ] must-fail [ "foo/bar/baz/.." parent-directory ] must-fail @@ -263,5 +258,4 @@ io.encodings.utf8 ; [ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test [ t ] [ "resource:core" absolute-path? ] unit-test -[ t ] [ "/foo" absolute-path? ] unit-test [ f ] [ "" absolute-path? ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 099acb157e..45bf0602f2 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream ) HOOK: (file-appender) io-backend ( path -- stream ) : ( path encoding -- stream ) - swap normalize-pathname (file-reader) swap ; + swap normalize-path (file-reader) swap ; : ( path encoding -- stream ) - swap normalize-pathname (file-writer) swap ; + swap normalize-path (file-writer) swap ; : ( path encoding -- stream ) - swap normalize-pathname (file-appender) swap ; + swap normalize-path (file-appender) swap ; : file-lines ( path encoding -- seq ) lines ; @@ -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 ; @@ -102,6 +102,7 @@ PRIVATE> : windows-absolute-path? ( path -- path ? ) { + { [ dup "\\\\?\\" head? ] [ t ] } { [ dup length 2 < ] [ f ] } { [ dup second CHAR: : = ] [ t ] } { [ t ] [ f ] } @@ -111,8 +112,8 @@ PRIVATE> { { [ dup empty? ] [ f ] } { [ dup "resource:" head? ] [ t ] } + { [ os windows? ] [ windows-absolute-path? ] } { [ dup first path-separator? ] [ t ] } - { [ windows? ] [ windows-absolute-path? ] } { [ t ] [ f ] } } cond nip ; @@ -126,6 +127,9 @@ PRIVATE> 2 tail left-trim-separators >r parent-directory r> append-path ] } + { [ over absolute-path? over first path-separator? and ] [ + >r 2 head r> append + ] } { [ t ] [ >r right-trim-separators "/" r> left-trim-separators 3append @@ -167,7 +171,7 @@ SYMBOL: +unknown+ ! File metadata : exists? ( path -- ? ) - normalize-pathname (exists?) ; + normalize-path (exists?) ; : directory? ( path -- ? ) file-info file-info-type +directory+ = ; @@ -183,18 +187,33 @@ M: object cwd ( -- path ) "." ; [ cwd current-directory set-global ] "io.files" add-init-hook +: resource-path ( path -- newpath ) + "resource-path" get [ image parent-directory ] unless* + prepend-path ; + +: (normalize-path) ( path -- path' ) + "resource:" ?head [ + left-trim-separators resource-path + (normalize-path) + ] [ + current-directory get prepend-path + ] if ; + +M: object normalize-path ( path -- path' ) + (normalize-path) ; + : with-directory ( path quot -- ) - >r normalize-pathname r> + >r (normalize-path) r> current-directory swap with-variable ; inline : set-current-directory ( path -- ) - normalize-pathname current-directory set ; + normalize-path current-directory set ; ! Creating directories HOOK: make-directory io-backend ( path -- ) : make-directories ( path -- ) - normalize-pathname right-trim-separators { + normalize-path right-trim-separators { { [ dup "." = ] [ ] } { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } @@ -267,7 +286,7 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) - normalize-pathname + normalize-path over link-info type>> { { +symbolic-link+ [ copy-link ] } @@ -286,9 +305,6 @@ DEFER: copy-tree-into [ copy-tree-into ] curry each ; ! Special paths -: resource-path ( path -- newpath ) - "resource-path" get [ image parent-directory ] unless* - prepend-path ; : temp-directory ( -- path ) "temp" resource-path dup make-directories ; @@ -296,14 +312,6 @@ DEFER: copy-tree-into : temp-file ( name -- path ) temp-directory prepend-path ; -M: object normalize-pathname ( path -- path' ) - "resource:" ?head [ - left-trim-separators resource-path - normalize-pathname - ] [ - current-directory get prepend-path - ] if ; - ! Pathname presentations TUPLE: pathname string ; @@ -314,7 +322,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/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index b1120de8e6..53618d4628 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -250,8 +250,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 } @@ -377,10 +378,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" } @@ -413,12 +417,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 +669,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 +685,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 +701,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 +804,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" } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index ab42a1b903..1935c89431 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,27 @@ GENERIC: construct-boa ( ... class -- tuple ) + +! Deprecated +GENERIC: delegate ( obj -- delegate ) + +M: object delegate drop f ; + +GENERIC: set-delegate ( delegate tuple -- ) + +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..089465177b 100755 --- a/core/layouts/layouts-docs.factor +++ b/core/layouts/layouts-docs.factor @@ -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/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index f6317e7475..5204d7d45a 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -188,7 +188,7 @@ IN: math.intervals.tests { max interval-max } } "math.ratios.private" vocab [ - { / interval/ } add + { / interval/ } suffix ] when random ; 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/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/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 aef48452de..2bce2dc94c 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -60,7 +60,7 @@ sequences.private combinators ; [ value-literal sequence? ] [ drop f ] if ; : member-quot ( seq -- newquot ) - [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ; + [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ; : expand-member ( #call -- ) dup node-in-d peek value-literal member-quot f splice-quot ; @@ -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/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 560a174289..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 ) @@ -32,7 +33,7 @@ IN: optimizer.specializers : method-declaration ( method -- quot ) dup "method-generic" word-prop dispatch# object - swap "method-class" word-prop add* ; + swap "method-class" word-prop prefix ; : specialize-method ( quot method -- quot' ) method-declaration [ declare ] curry prepend ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 36e5decd05..902bae29b5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -294,7 +294,7 @@ M: no-word-error summary scan { { ";" [ tuple f ] } { "<" [ scan-word ";" parse-tokens ] } - [ >r tuple ";" parse-tokens r> add* ] + [ >r tuple ";" parse-tokens r> prefix ] } case ; ERROR: staging-violation word ; @@ -365,7 +365,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? @@ -467,18 +477,22 @@ SYMBOL: interactive-vocabs 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@ ; + +: removed-classes ( -- assoc1 assoc2 ) + new-definitions old-definitions + [ get second ] bi@ ; : smudged-usage ( -- usages referenced removed ) - removed-definitions filter-moved keys [ + removed-definitions filter-moved [ outside-usages [ empty? [ drop f ] [ @@ -495,8 +509,10 @@ SYMBOL: interactive-vocabs : 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 + removed-classes + filter-moved [ class? ] subset [ reset-class ] each ; : forget-smudged ( -- ) smudged-usage forget-all @@ -505,9 +521,10 @@ SYMBOL: interactive-vocabs : 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/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 35b30ac46f..0f384b159d 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 @@ -192,7 +190,7 @@ unit-test "IN: prettyprint.tests" ": another-soft-break-layout ( node -- quot )" " parse-error-file" - " [ \"hello world foo\" add ] [ ] make ;" + " [ \"hello world foo\" suffix ] [ ] make ;" } ; [ t ] [ diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index d294f95be6..fd7133053a 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -7,7 +7,7 @@ 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 ; +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* 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 ; @@ -478,18 +481,18 @@ M: sequence <=> : push-new ( elt seq -- ) [ delete ] 2keep push ; -: add ( seq elt -- newseq ) - over >r over length 1+ r> [ - [ >r over length r> set-nth-unsafe ] keep - [ 0 swap copy ] keep - ] new-like ; - -: add* ( seq elt -- newseq ) +: prefix ( seq elt -- newseq ) over >r over length 1+ r> [ [ 0 swap set-nth-unsafe ] keep [ 1 swap copy ] keep ] new-like ; +: suffix ( seq elt -- newseq ) + over >r over length 1+ r> [ + [ >r over length r> set-nth-unsafe ] keep + [ 0 swap copy ] keep + ] new-like ; + : seq-diff ( seq1 seq2 -- newseq ) swap [ member? not ] curry subset ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index b674ec8c2a..e46e507b9d 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -14,7 +14,7 @@ C: slot-spec >r create-method r> define ; : define-slot-word ( class slot word quot -- ) - rot >fixnum add* define-typecheck ; + rot >fixnum prefix define-typecheck ; : reader-quot ( decl -- quot ) [ diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 9be1d5fc64..260a08c044 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -76,5 +76,5 @@ INSTANCE: groups sequence 1 head-slice* [ "\r" ?tail drop "\r" split ] map - ] keep peek "\r" split add concat + ] keep peek "\r" split suffix concat ] if ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index bd349953df..b242e65de5 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -243,7 +243,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" } 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.factor b/core/vocabs/loader/loader.factor index 57947eefb0..1489750154 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -20,7 +20,7 @@ V{ : vocab-dir+ ( vocab str/f -- path ) >r vocab-name "." split r> - [ >r dup peek r> append add ] when* + [ >r dup peek r> append suffix ] when* "/" join ; : vocab-dir? ( root name -- ? ) diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 886417b715..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 } @@ -82,7 +80,7 @@ SYMBOL: load-vocab-hook ! ( name -- ) : child-vocab? ( prefix name -- ? ) 2dup = pick empty? or - [ 2drop t ] [ swap CHAR: . add head? ] if ; + [ 2drop t ] [ swap CHAR: . suffix head? ] if ; : child-vocabs ( vocab -- seq ) vocab-name vocabs [ child-vocab? ] with subset ; @@ -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.factor b/core/words/words.factor index 5c0d84d4cc..059815e952 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 ; @@ -172,7 +173,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 +212,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 +220,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/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 30c3beb1ef..215b677e16 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -49,7 +49,7 @@ HINTS: random fixnum ; : make-cumulative ( freq -- chars floats ) dup keys >byte-array - swap values >float-array unclip [ + ] accumulate swap add ; + swap values >float-array unclip [ + ] accumulate swap suffix ; :: select-random ( seed chars floats -- seed elt ) floats seed random -rot 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 75664ce5e5..ece6d64ed9 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/cairo/png/png.factor b/extra/cairo/png/png.factor index 774a1afe8e..f9908e4581 100755 --- a/extra/cairo/png/png.factor +++ b/extra/cairo/png/png.factor @@ -24,7 +24,7 @@ ERROR: cairo-error string ; } cond ; : ( path -- png ) - normalize-pathname + normalize-path cairo_image_surface_create_from_png dup cairo_surface_status cairo-png-error dup [ cairo_image_surface_get_width check-zero ] 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/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 8a1d93aceb..63fd55a550 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -32,7 +32,7 @@ VAR: color ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ; +: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ; : gl-set-hsba ( hsva -- ) hsva>rgba gl-color ; diff --git a/extra/cocoa/subclassing/subclassing.factor b/extra/cocoa/subclassing/subclassing.factor index 42ddce1206..48f45f21c0 100755 --- a/extra/cocoa/subclassing/subclassing.factor +++ b/extra/cocoa/subclassing/subclassing.factor @@ -76,7 +76,7 @@ IN: cocoa.subclassing r> class_addMethods ; : encode-types ( return types -- encoding ) - swap add* [ + swap prefix [ alien>objc-types get at "0" append ] map concat ; diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 647c83d667..0480235dfe 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -21,7 +21,7 @@ M: color-preview model-changed swap model-value over set-gadget-interior relayout-1 ; : ( model -- model ) - [ [ 256 /f ] map 1 add ] ; + [ [ 256 /f ] map 1 suffix ] ; : ( -- model gadget ) 3 [ drop 0 0 0 255 ] map diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index d99fe7e1d2..8018adaaa4 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,5 +1,5 @@ -USING: kernel sequences macros combinators ; +USING: kernel arrays sequences macros combinators ; IN: combinators.cleave @@ -21,6 +21,18 @@ MACRO: <2arr> ( seq -- ) [ >quots ] [ length ] bi '[ , 2cleave , narray ] ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: {1} ( x -- {x} ) 1array ; inline +: {2} ( x y -- {x,y} ) 2array ; inline +: {3} ( x y z -- {x,y,z} ) 3array ; inline + +: {n} narray ; + +: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline + +: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Spread into array ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -28,3 +40,8 @@ MACRO: <2arr> ( seq -- ) MACRO: ( seq -- ) [ >quots ] [ length ] bi '[ , spread , narray ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline +: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index 856c37a6bc..e2abd6deb9 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -1,33 +1,33 @@ -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 - { - { [ unix? ] [ "distributed-concurrency-test" temp-file ] } - { [ 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/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/db/types/types.factor b/extra/db/types/types.factor index 9babfbcdb0..98bc451a6f 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes mirrors classes.tuple combinators calendar.format symbols -singleton ; +classes.singleton ; IN: db.types HOOK: modifier-table db ( -- hash ) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 7f24d6258f..eadd1a03e8 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -27,7 +27,7 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add >r swap create-method r> define ; + pick suffix >r swap create-method r> define ; : define-consult ( class group quot -- ) >r group-words swap r> diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 85d58e7572..e871d5f808 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -26,7 +26,7 @@ SYMBOL: edit-hook require ; : edit-location ( file line -- ) - >r normalize-pathname "\\\\?\\" ?head drop r> + >r (normalize-path) "\\\\?\\" ?head drop r> edit-hook get [ call ] [ no-edit-hook edit-location ] if* ; : edit ( defspec -- ) @@ -43,7 +43,7 @@ SYMBOL: edit-hook : fix ( word -- ) "Fixing " write dup pprint " and all usages..." print nl - dup usage swap add* [ + dup usage swap prefix [ "Editing " write dup . "RETURN moves on to the next usage, C+d stops." print flush 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/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/faq/faq.factor b/extra/faq/faq.factor index c6d9cd04d2..1022a02d7e 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -69,7 +69,7 @@ C: faq : html>faq ( div -- faq ) unclip swap { "h3" "ol" } [ tags-named ] with map - first2 >r f add* r> [ html>question-list ] 2map ; + first2 >r f prefix r> [ html>question-list ] 2map ; : header, ( faq -- ) dup faq-header , 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/fry/fry.factor b/extra/fry/fry.factor index 490ce992ab..d983bd2715 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -28,7 +28,7 @@ DEFER: (fry) ! to avoid confusion, remove if fry goes core { namespaces:, [ [ curry ] ((fry)) ] } - [ swap >r add r> (fry) ] + [ swap >r suffix r> (fry) ] } case ] if ; diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 69b8678749..ecdcc42cb5 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -6,11 +6,9 @@ IN: hardware-info : megs. ( x -- ) 20 2^ /f . ; : gigs. ( x -- ) 30 2^ /f . ; -<< -{ - { [ windows? ] [ "hardware-info.windows" ] } - { [ linux? ] [ "hardware-info.linux" ] } - { [ macosx? ] [ "hardware-info.macosx" ] } +<< { + { [ os windows? ] [ "hardware-info.windows" ] } + { [ os linux? ] [ "hardware-info.linux" ] } + { [ os macosx? ] [ "hardware-info.macosx" ] } { [ t ] [ f ] } } cond [ require ] when* >> - 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/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 1c2dfde85c..847a5952af 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -152,6 +152,7 @@ ARTICLE: "collections" "Collections" "Implementations:" { $subsection "hashtables" } { $subsection "alists" } +{ $subsection "enums" } { $heading "Other collections" } { $subsection "boxes" } { $subsection "dlists" } @@ -261,7 +262,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/help/markup/markup.factor b/extra/help/markup/markup.factor index f8d360fd0a..b963a19f29 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -234,7 +234,7 @@ M: string ($instance) : values-row ( seq -- seq ) unclip \ $snippet swap ?word-name 2array - swap dup first word? [ \ $instance add* ] when 2array ; + swap dup first word? [ \ $instance prefix ] when 2array ; : $values ( element -- ) "Inputs and outputs" $heading diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index 1e84e544b8..deab40e8d4 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -1,42 +1,42 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: db db.tuples db.types accessors -http.server.auth.providers kernel continuations -singleton ; -IN: http.server.auth.providers.db - -user "USERS" -{ - { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ } - { "realname" "REALNAME" { VARCHAR 256 } } - { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } - { "email" "EMAIL" { VARCHAR 256 } } - { "ticket" "TICKET" { VARCHAR 256 } } - { "profile" "PROFILE" FACTOR-BLOB } -} define-persistent - -: init-users-table user ensure-table ; - -SINGLETON: users-in-db - -: find-user ( username -- user ) - - swap >>username - select-tuple ; - -M: users-in-db get-user - drop - find-user ; - -M: users-in-db new-user - drop - [ - dup username>> find-user [ - drop f - ] [ - dup insert-tuple - ] if - ] with-transaction ; - -M: users-in-db update-user - drop update-tuple ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db db.tuples db.types accessors +http.server.auth.providers kernel continuations +classes.singleton ; +IN: http.server.auth.providers.db + +user "USERS" +{ + { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ } + { "realname" "REALNAME" { VARCHAR 256 } } + { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } + { "email" "EMAIL" { VARCHAR 256 } } + { "ticket" "TICKET" { VARCHAR 256 } } + { "profile" "PROFILE" FACTOR-BLOB } +} define-persistent + +: init-users-table user ensure-table ; + +SINGLETON: users-in-db + +: find-user ( username -- user ) + + swap >>username + select-tuple ; + +M: users-in-db get-user + drop + find-user ; + +M: users-in-db new-user + drop + [ + dup username>> find-user [ + drop f + ] [ + dup insert-tuple + ] if + ] with-transaction ; + +M: users-in-db update-user + drop update-tuple ; diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index 471b7fa6df..e573b22ba1 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -1,46 +1,46 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs accessors http.server.sessions.storage -alarms kernel http.server db.tuples db.types singleton -math.parser ; -IN: http.server.sessions.storage.db - -SINGLETON: sessions-in-db - -TUPLE: session id namespace ; - -session "SESSIONS" -{ - { "id" "ID" INTEGER +native-id+ } - { "namespace" "NAMESPACE" FACTOR-BLOB } -} define-persistent - -: init-sessions-table session ensure-table ; - -: ( id -- session ) - session construct-empty - swap dup [ string>number ] when >>id ; - -M: sessions-in-db get-session ( id storage -- namespace/f ) - drop - dup [ - - select-tuple dup [ namespace>> ] when - ] when ; - -M: sessions-in-db update-session ( namespace id storage -- ) - drop - - swap >>namespace - update-tuple ; - -M: sessions-in-db delete-session ( id storage -- ) - drop - - delete-tuple ; - -M: sessions-in-db new-session ( namespace storage -- id ) - drop - f - swap >>namespace - [ insert-tuple ] [ id>> number>string ] bi ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs accessors http.server.sessions.storage +alarms kernel http.server db.tuples db.types math.parser +classes.singleton ; +IN: http.server.sessions.storage.db + +SINGLETON: sessions-in-db + +TUPLE: session id namespace ; + +session "SESSIONS" +{ + { "id" "ID" INTEGER +native-id+ } + { "namespace" "NAMESPACE" FACTOR-BLOB } +} define-persistent + +: init-sessions-table session ensure-table ; + +: ( id -- session ) + session construct-empty + swap dup [ string>number ] when >>id ; + +M: sessions-in-db get-session ( id storage -- namespace/f ) + drop + dup [ + + select-tuple dup [ namespace>> ] when + ] when ; + +M: sessions-in-db update-session ( namespace id storage -- ) + drop + + swap >>namespace + update-tuple ; + +M: sessions-in-db delete-session ( id storage -- ) + drop + + delete-tuple ; + +M: sessions-in-db new-session ( namespace storage -- id ) + drop + f + swap >>namespace + [ insert-tuple ] [ id>> number>string ] bi ; 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/sockets/sockets.factor b/extra/io/sockets/sockets.factor index e1cc36cd2e..17799227b8 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -7,7 +7,7 @@ IN: io.sockets TUPLE: local path ; : ( path -- addrspec ) - normalize-pathname local construct-boa ; + normalize-path local construct-boa ; TUPLE: inet4 host port ; 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 bb2039adfb..040b191d27 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -21,3 +21,9 @@ IN: io.unix.files.tests [ "/lib/" ] [ "/" "../lib/" append-path ] unit-test [ "/lib" ] [ "/" "../../lib" append-path ] unit-test [ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test + +[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test +[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test +[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test +[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test +[ t ] [ "/foo" absolute-path? ] unit-test diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index c4e506d37f..f6bb3edcde 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -3,15 +3,15 @@ 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 ; 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 +19,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 +27,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,29 +36,29 @@ 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 -- ) - normalize-pathname +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 -- ) - [ normalize-pathname ] bi@ rename io-error ; +M: unix move-file ( from to -- ) + [ normalize-path ] bi@ rename io-error ; -M: unix-io delete-file ( path -- ) - normalize-pathname unlink io-error ; +M: unix delete-file ( path -- ) + normalize-path unlink io-error ; -M: unix-io make-directory ( path -- ) - normalize-pathname OCT: 777 mkdir io-error ; +M: unix make-directory ( path -- ) + normalize-path OCT: 777 mkdir io-error ; -M: unix-io delete-directory ( path -- ) - normalize-pathname rmdir io-error ; +M: unix delete-directory ( path -- ) + normalize-path rmdir io-error ; : (copy-file) ( from to -- ) dup parent-directory make-directories @@ -68,8 +68,8 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ] with-disposal ; -M: unix-io copy-file ( from to -- ) - [ normalize-pathname ] bi@ +M: unix copy-file ( from to -- ) + [ normalize-path ] bi@ [ (copy-file) ] [ swap file-info file-info-permissions chmod io-error ] 2bi ; @@ -95,16 +95,16 @@ M: unix-io copy-file ( from to -- ) } cleave \ file-info construct-boa ; -M: unix-io file-info ( path -- info ) - normalize-pathname stat* stat>file-info ; +M: unix file-info ( path -- info ) + normalize-path stat* stat>file-info ; -M: unix-io link-info ( path -- info ) - normalize-pathname lstat* stat>file-info ; +M: unix link-info ( path -- info ) + normalize-path lstat* stat>file-info ; -M: unix-io make-link ( path1 path2 -- ) - normalize-pathname symlink io-error ; +M: unix make-link ( path1 path2 -- ) + normalize-path symlink io-error ; -M: unix-io read-link ( path -- path' ) - normalize-pathname +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 f738bd42c2..8e5531a40c 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -37,7 +37,7 @@ USE: unix 2nip reset-fd ; : redirect-file ( obj mode fd -- ) - >r >r normalize-pathname r> file-mode + >r >r normalize-path r> file-mode open dup io-error r> redirect-fd ; : redirect-closed ( obj mode fd -- ) @@ -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..477757e0ed 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 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 c4f5b2ef9e..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-pathname ( 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 295b3ab006..4f31d2dfce 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -3,7 +3,7 @@ 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 ; +combinators.lib io.nonblocking destructors system ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ @@ -88,15 +88,15 @@ SYMBOLS: +read-only+ +hidden+ +system+ get-file-information BY_HANDLE_FILE_INFORMATION>file-info ] if ; -M: windows-nt-io file-info ( path -- info ) - normalize-pathname get-file-information-stat ; +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 ) [ - normalize-pathname open-existing dup close-always + normalize-path open-existing dup close-always "FILETIME" "FILETIME" "FILETIME" @@ -112,7 +112,7 @@ M: windows-nt-io link-info ( path -- info ) #! timestamp order: creation access write [ >r >r >r - normalize-pathname open-existing dup close-always + normalize-path open-existing dup close-always r> r> r> (set-file-times) ] with-destructors ; @@ -125,9 +125,9 @@ 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-pathname + normalize-path maybe-create-file over close-always [ drop ] [ f now dup (set-file-times) ] if ] with-destructors ; 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 31247e43c3..2724966a8f 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -28,7 +28,7 @@ TUPLE: CreateProcess-args "PROCESS_INFORMATION" >>lpProcessInformation TRUE >>bInheritHandles 0 >>dwCreateFlags - current-directory get normalize-pathname >>lpCurrentDirectory ; + current-directory get (normalize-path) >>lpCurrentDirectory ; : 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,20 +101,20 @@ 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 @@ -122,7 +122,7 @@ M: windows-io run-process* ( process -- handle ) 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 +161,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-tests.factor b/extra/io/windows/nt/files/files-tests.factor old mode 100644 new mode 100755 index 73d6a0bf7f..1e6268fbc0 --- a/extra/io/windows/nt/files/files-tests.factor +++ b/extra/io/windows/nt/files/files-tests.factor @@ -1,9 +1,9 @@ USING: io.files kernel tools.test io.backend -io.windows.nt.files splitting ; +io.windows.nt.files splitting sequences ; IN: io.windows.nt.files.tests -[ t ] [ "\\foo" absolute-path? ] unit-test -[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test +[ f ] [ "\\foo" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test [ t ] [ "c:\\foo" absolute-path? ] unit-test [ t ] [ "c:" absolute-path? ] unit-test @@ -29,19 +29,22 @@ IN: io.windows.nt.files.tests [ ] [ "" resource-path cd ] unit-test -[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test +[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test [ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ "C:\\builds\\factor\\12345\\" - "..\\log.txt" append-path normalize-pathname + "..\\log.txt" append-path normalize-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-pathname + "..\\.." append-path normalize-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-pathname + "..\\.." append-path normalize-path ] unit-test + +[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test +[ t ] [ "" resource-path 2 tail exists? ] unit-test diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 81112a89c0..7bac540ddc 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,22 +1,22 @@ 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 ; 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 ] } @@ -36,33 +36,19 @@ ERROR: not-absolute-path ; } && [ 2 head ] [ not-absolute-path ] if ; : prepend-prefix ( string -- string' ) - unicode-prefix prepend ; + dup unicode-prefix head? [ + unicode-prefix prepend + ] unless ; -ERROR: nonstring-pathname ; -ERROR: empty-pathname ; +M: winnt normalize-path ( string -- string' ) + (normalize-path) + { { CHAR: / CHAR: \\ } } substitute + prepend-prefix ; -M: windows-nt-io normalize-pathname ( string -- string ) - "resource:" ?head [ - left-trim-separators resource-path - normalize-pathname - ] [ - dup empty? [ empty-pathname ] when - current-directory get prepend-path - dup unicode-prefix head? [ - dup first path-separator? [ - left-trim-separators - current-directory get 2 head - prepend-path - ] when - unicode-prefix prepend - ] unless - { { CHAR: / CHAR: \\ } } substitute ! necessary - ] if ; - -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 c342b2ee9a..4bbf7c8e32 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -32,7 +32,7 @@ IN: io.windows.nt.launcher drop 2nip null-pipe ; :: redirect-file ( default path access-mode create-mode -- handle ) - path normalize-pathname + path normalize-path access-mode share-mode security-attributes-inherit @@ -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 27917cedfa..7755f111c6 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,8 +20,8 @@ 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 ) - normalize-pathname "\\" ?tail drop "\\*" append ; +M: windows normalize-directory ( string -- string ) + normalize-path "\\" ?tail drop "\\*" append ; : share-mode ( -- fixnum ) { @@ -125,31 +121,31 @@ 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 -- ) - [ normalize-pathname ] bi@ MoveFile win32-error=0/f ; +M: windows move-file ( from to -- ) + [ normalize-path ] bi@ MoveFile win32-error=0/f ; -M: windows-io delete-file ( path -- ) - normalize-pathname DeleteFile win32-error=0/f ; +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-pathname ] bi@ 0 CopyFile win32-error=0/f ; + [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ; -M: windows-io make-directory ( path -- ) - normalize-pathname +M: windows make-directory ( path -- ) + normalize-path f CreateDirectory win32-error=0/f ; -M: windows-io delete-directory ( path -- ) - normalize-pathname +M: windows delete-directory ( path -- ) + normalize-path RemoveDirectory win32-error=0/f ; HOOK: WSASocket-flags io-backend ( -- DWORD ) @@ -194,7 +190,7 @@ 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 ) diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index f286690d37..add37173b7 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -184,7 +184,7 @@ DEFER: (d) [ length ] keep [ (graded-ker/im-d) ] curry map ; : graded-betti ( generators -- seq ) - basis graded graded-ker/im-d flip first2 1 head* 0 add* v- ; + basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ; ! Bi-graded for two-step complexes : (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank ) @@ -203,7 +203,7 @@ DEFER: (d) [ basis graded ] bi@ tensor bigraded-ker/im-d [ [ [ first ] map ] map ] keep [ [ second ] map 2 head* { 0 0 } prepend ] map - 1 tail dup first length 0 add + 1 tail dup first length 0 suffix [ v- ] 2map ; ! Laplacian diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 52cca64b2f..f642d8881c 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -365,7 +365,7 @@ M: lazy-concat nil? ( lazy-concat -- bool ) drop nil ] [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ add ] lmap-with ] lmap-with lconcat + swap [ swap [ suffix ] lmap-with ] lmap-with lconcat ] reduce ] if ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 5da0225be9..fe4bd65c14 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -108,7 +108,7 @@ UNION: special local quote local-word local-reader local-writer ; : point-free-end ( quot args -- newquot ) over peek special? [ drop-locals >r >r peek r> localize r> append ] - [ drop-locals nip swap peek add ] + [ drop-locals nip swap peek suffix ] if ; : (point-free) ( quot args -- newquot ) @@ -130,9 +130,9 @@ GENERIC: free-vars ( form -- vars ) : add-if-free ( vars object -- vars ) { - { [ dup local-writer? ] [ "local-reader" word-prop add ] } - { [ dup lexical? ] [ add ] } - { [ dup quote? ] [ quote-local add ] } + { [ dup local-writer? ] [ "local-reader" word-prop suffix ] } + { [ dup lexical? ] [ suffix ] } + { [ dup quote? ] [ quote-local suffix ] } { [ t ] [ free-vars append ] } } cond ; diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 42545500a5..664337c3d3 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -17,7 +17,7 @@ SYMBOL: CRITICAL { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; : send-to-log-server ( array string -- ) - add* "log-server" get send ; + prefix "log-server" get send ; SYMBOL: log-service diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor index d8429e7aaf..87536476ee 100644 --- a/extra/lsys/tortoise/graphics/graphics.factor +++ b/extra/lsys/tortoise/graphics/graphics.factor @@ -77,7 +77,7 @@ VAR: color-table { 0.25 0.25 0.25 } ! dark grey { 0.75 0.75 0.75 } ! medium grey { 1 1 1 } ! white -} [ 1 add ] map >color-table ; +} [ 1 suffix ] map >color-table ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index 99a098ca09..487d9828ea 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -18,7 +18,7 @@ IN: math.combinatorics 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ; : (>permutation) ( seq n -- seq ) - [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ; + [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ; : >permutation ( factoradic -- permutation ) reverse 1 cut [ (>permutation) ] each ; diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index d6ac71e629..0b0d3520ef 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -22,7 +22,7 @@ PRIVATE> : p= ( p p -- ? ) pextend = ; : ptrim ( p -- p ) - dup singleton? [ [ zero? ] right-trim ] unless ; + dup length 1 = [ [ zero? ] right-trim ] unless ; : 2ptrim ( p p -- p p ) [ ptrim ] bi@ ; : p+ ( p p -- p ) pextend v+ ; diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index b77ac725ab..cba8c28310 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -79,7 +79,7 @@ SYMBOL: and-needed? ] if ; : recombine ( seq -- str ) - dup singleton? [ + dup length 1 = [ first 3digits>text ] [ dup set-conjunction "" swap 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/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index ac62fb08f9..5ea19bc957 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -191,14 +191,14 @@ M: hook-combination generic-prologue [ delete-at ] with-methods ; : method>spec ( method -- spec ) - dup method-classes swap method-generic add* ; + dup method-classes swap method-generic prefix ; : parse-method ( -- quot classes generic ) parse-definition dup 2 tail over second rot first ; : METHOD: location - >r parse-method [ define-method ] 2keep add* r> + >r parse-method [ define-method ] 2keep prefix r> remember-definition ; parsing ! For compatibility diff --git a/extra/new-effects/new-effects.factor b/extra/new-effects/new-effects.factor deleted file mode 100644 index f073ccadd3..0000000000 --- a/extra/new-effects/new-effects.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: assocs kernel sequences ; -IN: new-effects - -: new-nth ( seq n -- elt ) - swap nth ; inline - -: new-set-nth ( seq obj n -- seq ) - pick set-nth ; inline - -: new-at ( assoc key -- elt ) - swap at ; inline - -: new-at* ( assoc key -- elt ? ) - swap at* ; inline - -: new-set-at ( assoc value key -- assoc ) - pick set-at ; inline diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor new file mode 100644 index 0000000000..53cda66dfc --- /dev/null +++ b/extra/newfx/newfx.factor @@ -0,0 +1,68 @@ + +USING: kernel sequences assocs qualified ; + +QUALIFIED: sequences + +IN: newfx + +! Now, we can see a new world coming into view. +! A world in which there is the very real prospect of a new world order. +! +! - George Herbert Walker Bush + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: nth-at ( seq i -- val ) swap nth ; +: nth-of ( i seq -- val ) nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: nth-is ( seq i val -- seq ) swap pick set-nth ; +: is-nth ( seq val i -- seq ) pick set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mutate-nth ( seq i val -- ) swap rot set-nth ; +: mutate-at-nth ( seq val i -- ) rot set-nth ; + +: mutate-nth-of ( i val seq -- ) swapd set-nth ; +: mutate-at-nth-of ( val i seq -- ) set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: at-key ( tbl key -- val ) swap at ; +: key-of ( key tbl -- val ) at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: key-is ( tbl key val -- tbl ) swap pick set-at ; +: is-key ( tbl val key -- tbl ) pick set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mutate-key ( tbl key val -- ) swap rot set-at ; +: mutate-at-key ( tbl val key -- ) rot set-at ; + +: mutate-key-of ( key val tbl -- ) swapd set-at ; +: mutate-at-key-of ( val key tbl -- ) set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: push ( seq obj -- seq ) over sequences:push ; +: push-on ( obj seq -- seq ) tuck sequences:push ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: member? ( seq obj -- ? ) swap sequences:member? ; +: member-of? ( obj seq -- ? ) sequences:member? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: delete-at-key ( tbl key -- tbl ) over delete-at ; +: delete-key-of ( key tbl -- tbl ) tuck delete-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! A note about the 'mutate' qualifier. Other words also technically mutate +! their primary object. However, the 'mutate' qualifier is supposed to +! indicate that this is the main objective of the word, as a side effect. \ No newline at end of file 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 01725ee9a9..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 @@ -38,7 +40,7 @@ reset-gl-function-number-counter gl-function-calling-convention scan scan dup - scan drop "}" parse-tokens swap add* + scan drop "}" parse-tokens swap prefix gl-function-number [ gl-function-pointer ] 2curry swap ";" parse-tokens [ "()" subseq? not ] subset 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/oracle/oracle.factor b/extra/oracle/oracle.factor index d725de5994..a30ce64854 100644 --- a/extra/oracle/oracle.factor +++ b/extra/oracle/oracle.factor @@ -236,13 +236,13 @@ C: connection : fetch-each ( object -- object ) fetch-statement [ - buf get alien>char-string res get swap add res set + buf get alien>char-string res get swap suffix res set fetch-each ] [ ] if ; : run-query ( object -- object ) execute-statement [ - buf get alien>char-string res get swap add res set + buf get alien>char-string res get swap suffix res set fetch-each ] [ ] if ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index d6aacf9645..d8fccfb8f9 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -132,7 +132,7 @@ TUPLE: and-parser parsers ; : <&> ( parser1 parser2 -- parser ) over and-parser? [ - >r and-parser-parsers r> add + >r and-parser-parsers r> suffix ] [ 2array ] if and-parser construct-boa ; @@ -239,11 +239,11 @@ M: some-parser parse ( input parser -- result ) : <:&> ( parser1 parser2 -- result ) #! Same as <&> except flatten the result. - <&> [ first2 add ] <@ ; + <&> [ first2 suffix ] <@ ; : <&:> ( parser1 parser2 -- result ) #! Same as <&> except flatten the result. - <&> [ first2 swap add* ] <@ ; + <&> [ first2 swap prefix ] <@ ; : <:&:> ( parser1 parser2 -- result ) #! Same as <&> except flatten the result. diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 9e35c5b9be..3e0ce815f0 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -104,7 +104,7 @@ C: peg-head :: (setup-lr) ( r l s -- ) s head>> l head>> eq? [ l head>> s (>>head) - l head>> [ s rule>> add ] change-involved-set drop + l head>> [ s rule>> suffix ] change-involved-set drop r l s next>> (setup-lr) ] unless ; @@ -136,7 +136,7 @@ C: peg-head h [ p heads get at ] | h [ - m r h involved-set>> h rule>> add member? not and [ + m r h involved-set>> h rule>> suffix member? not and [ fail p ] [ r h eval-set>> member? [ diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index ffe3a4bca1..cf09277f31 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -76,10 +76,10 @@ PRIVATE> dup first 2 tail* swap second 2 head = ; : clean ( seq -- seq ) - [ unclip 1 head add* concat ] map [ all-unique? ] subset ; + [ unclip 1 head prefix concat ] map [ all-unique? ] subset ; : add-missing-digit ( seq -- seq ) - dup natural-sort 10 seq-diff first add* ; + dup natural-sort 10 seq-diff first prefix ; : interesting-pandigitals ( -- seq ) 17 candidates { 13 11 7 5 3 2 } [ diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 087b216b3a..5829f66c01 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -72,7 +72,7 @@ PRIVATE> : max-path ( triangle -- n ) dup length 1 > [ - 2 cut* first2 max-children [ + ] 2map add max-path + 2 cut* first2 max-children [ + ] 2map suffix max-path ] [ first first ] if ; @@ -95,7 +95,7 @@ PRIVATE> ! Not strictly needed, but it is nice to be able to dump the triangle after the ! propagation : propagate-all ( triangle -- newtriangle ) - reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ; + reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap suffix ; : sum-divisors ( n -- sum ) dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ; diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index b4eb4558fa..69e4c09b6e 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -4,7 +4,7 @@ IN: qualified : define-qualified ( vocab-name -- ) dup require - dup vocab-words swap CHAR: : add + dup vocab-words swap CHAR: : suffix [ -rot >r append r> ] curry assoc-map use get push ; diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 8ddbdac6f4..77054ea377 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,7 +4,7 @@ ! 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 ; 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 @@ -27,8 +25,8 @@ TUPLE: mersenne-twister seq i ; 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 ] + [ >r dup 1+ r> calculate-y ] + [ >r mt-m + r> nth ] [ drop ] 2tri ; : mt-generate ( mt -- ) @@ -36,7 +34,7 @@ TUPLE: mersenne-twister seq i ; [ 0 >>i drop ] bi ; : init-mt-first ( seed -- seq ) - >r mt-n 0 r> + >r mt-n 0 r> HEX: ffffffff bitand 0 pick set-nth ; : init-mt-formula ( seq i -- f(seq[i]) ) diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index f3f55007f0..6a72baa21b 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,5 +1,5 @@ USING: alien.c-types io io.files io.nonblocking kernel -namespaces random io.encodings.binary singleton init +namespaces random io.encodings.binary init accessors system ; IN: random.unix @@ -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/regexp/regexp.factor b/extra/regexp/regexp.factor index fa36a7c6f8..b0cd61bd8f 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -21,7 +21,7 @@ SYMBOL: ignore-case? if 2curry ; : or-predicates ( quots -- quot ) - [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; + [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ; : <@literal [ nip ] curry <@ ; diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor index 1f2bbde171..8c26d880f1 100644 --- a/extra/regexp2/regexp2.factor +++ b/extra/regexp2/regexp2.factor @@ -21,7 +21,7 @@ SYMBOL: ignore-case? if 2curry ; : or-predicates ( quots -- quot ) - [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; + [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ; : literal-action [ nip ] curry action ; 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/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor index 541570f3f9..9629d569cb 100755 --- a/extra/sequences/deep/deep-tests.factor +++ b/extra/sequences/deep/deep-tests.factor @@ -11,7 +11,7 @@ IN: sequences.deep.tests [ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test : change-something ( seq -- newseq ) - dup array? [ "hi" add ] [ "hello" append ] if ; + dup array? [ "hi" suffix ] [ "hello" append ] if ; [ { { "heyhello" "hihello" } "hihello" } ] [ "hey" 1array 1array [ change-something ] deep-map ] unit-test diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 6e6a924382..99565e966c 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -46,9 +46,6 @@ IN: sequences.lib.tests [ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test [ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ] [ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test -[ f ] [ { } singleton? ] unit-test -[ t ] [ { "asdf" } singleton? ] unit-test -[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test [ V{ } [ delete-random drop ] keep length ] must-fail diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0b93552e76..945ba1a3b7 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -94,13 +94,10 @@ MACRO: firstn ( n -- ) : monotonic-split ( seq quot -- newseq ) [ - >r dup unclip add r> + >r dup unclip suffix r> v, [ pick ,, call [ v, ] unless ] curry 2each ,v ] { } make ; -: singleton? ( seq -- ? ) - length 1 = ; - : delete-random ( seq -- value ) [ length random ] keep [ nth ] 2keep delete-nth ; diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor deleted file mode 100644 index 92ddcc494a..0000000000 --- a/extra/singleton/singleton-docs.factor +++ /dev/null @@ -1,26 +0,0 @@ -USING: help.markup help.syntax kernel words ; -IN: 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: -} ; - -HELP: SINGLETONS: -{ $syntax "SINGLETONS: classes... ;" -} { $values - { "classes" "new singletons to define" } -} { $description - "Defines a new singleton for each class in the list." -} { $examples - { $example "USE: singleton" "SINGLETONS: foo bar baz ;" "" } -} { $see-also - POSTPONE: SINGLETON: -} ; diff --git a/extra/singleton/singleton-tests.factor b/extra/singleton/singleton-tests.factor deleted file mode 100644 index 1698181ed3..0000000000 --- a/extra/singleton/singleton-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -USING: kernel singleton tools.test ; -IN: singleton.tests - -[ ] [ SINGLETON: bzzt ] unit-test -[ t ] [ bzzt bzzt? ] unit-test -[ t ] [ bzzt bzzt eq? ] unit-test -GENERIC: zammo ( obj -- ) -[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test -[ "yes!" ] [ bzzt zammo ] unit-test diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor deleted file mode 100755 index 9ec9f2f4a3..0000000000 --- a/extra/singleton/singleton.factor +++ /dev/null @@ -1,16 +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 ; -IN: singleton - -: define-singleton ( token -- ) - create-class-in - \ word - over [ eq? ] curry define-predicate-class ; - -: SINGLETON: - scan define-singleton ; parsing - -: SINGLETONS: - ";" parse-tokens [ define-singleton ] each ; parsing 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/springies/springies.factor b/extra/springies/springies.factor index 3a1af786e2..cd6e1a7cfb 100644 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -235,7 +235,7 @@ C: spring 6 nrot 6 nrot 2array 5 nrot 5 nrot 2array 0 0 2array - nodes> swap add >nodes ; + nodes> swap suffix >nodes ; : spng ( id id-a id-b k damp rest-length -- ) 6 nrot drop @@ -243,4 +243,4 @@ C: spring 5 nrot node-id 5 nrot node-id - springs> swap add >springs ; + springs> swap suffix >springs ; diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor index cd3cfc6324..489b7aaeb4 100755 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -6,7 +6,7 @@ IN: state-machine ! STATES: set-name state1 state2 ... ; ";" parse-tokens [ length ] keep - unclip add + unclip suffix [ create-in swap 1quotation define ] 2each ; parsing TUPLE: state place data ; diff --git a/extra/tetris/board/board.factor b/extra/tetris/board/board.factor index 13850f6bd7..93bbebf34f 100644 --- a/extra/tetris/board/board.factor +++ b/extra/tetris/board/board.factor @@ -37,7 +37,7 @@ TUPLE: board width height rows ; : add-row ( board -- ) dup board-rows over board-width f - add* swap set-board-rows ; + prefix swap set-board-rows ; : top-up-rows ( board -- ) dup board-height over board-rows length = [ diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index b019326ed5..e11d16c4ec 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -46,7 +46,7 @@ IN: tools.deploy.backend : staging-image-name ( profile -- name ) "staging." - swap strip-word-names? [ "strip" add ] when + swap strip-word-names? [ "strip" suffix ] when "-" join ".image" 3append temp-file ; DEFER: ?make-staging-image @@ -75,7 +75,7 @@ DEFER: ?make-staging-image ] { } make ; : run-factor ( vm flags -- ) - swap add* dup . run-with-output ; inline + swap prefix dup . run-with-output ; inline : make-staging-image ( profile -- ) vm swap staging-command-line run-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/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/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index d7610c21c8..2f941ad2ce 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -230,7 +230,7 @@ MEMO: all-vocabs-seq ( -- seq ) try-everything load-failures. ; : unrooted-child-vocabs ( prefix -- seq ) - dup empty? [ CHAR: . add ] unless + dup empty? [ CHAR: . suffix ] unless vocabs [ find-vocab-root not ] subset [ @@ -242,7 +242,7 @@ MEMO: all-vocabs-seq ( -- seq ) vocab-roots get [ dup pick (all-child-vocabs) [ >vocab-link ] map ] { } map>assoc - swap unrooted-child-vocabs f swap 2array add ; + swap unrooted-child-vocabs f swap 2array suffix ; : all-child-vocabs-seq ( prefix -- assoc ) vocab-roots get swap [ diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 2aed793a59..6bd8ace877 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -3,7 +3,7 @@ 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 ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -49,10 +49,17 @@ DEFER: start-walker-thread \ break t "break?" set-word-prop : walk ( quot -- quot' ) - \ break add* [ break rethrow ] recover ; + \ break prefix [ break rethrow ] recover ; -: add-breakpoint ( quot -- quot' ) - dup [ break ] head? [ \ break add* ] unless ; +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 ; @@ -74,7 +81,7 @@ DEFER: start-walker-thread \ (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 +101,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' ) [ @@ -114,7 +124,7 @@ SYMBOL: +stopped+ ] change-frame ; : step-out-msg ( continuation -- continuation' ) - [ nip \ break add ] change-frame ; + [ nip \ break suffix ] change-frame ; { { call [ (step-into-quot) ] } @@ -143,6 +153,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 +188,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/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor index 789d9b9e6a..ed524148e3 100644 --- a/extra/ui/commands/commands-docs.factor +++ b/extra/ui/commands/commands-docs.factor @@ -14,7 +14,7 @@ IN: ui.commands : command-map. ( command-map -- ) [ command-map-row ] map { "Shortcut" "Command" "Word" "Notes" } - [ \ $strong swap ] { } map>assoc add* + [ \ $strong swap ] { } map>assoc prefix $table ; : $command-map ( element -- ) 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/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor index fce88c0ebb..533116824b 100755 --- a/extra/ui/gadgets/grid-lines/grid-lines.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines.factor @@ -18,7 +18,7 @@ SYMBOL: grid-dim grid-dim get spin set-axis ; : draw-grid-lines ( gaps orientation -- ) - grid get rot grid-positions grid get rect-dim add [ + grid get rot grid-positions grid get rect-dim suffix [ grid-line-from/to gl-line ] with each ; diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 52c5ca8a02..91b7f0f225 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -352,7 +352,7 @@ M: f sloppy-pick-up* : sloppy-pick-up ( loc gadget -- path ) 2dup sloppy-pick-up* dup - [ [ wet-and-sloppy sloppy-pick-up ] keep add* ] + [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ] [ 3drop { } ] if ; diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor index 5ea1ec20fa..ab2abeec5b 100644 --- a/extra/ui/gadgets/slate/slate.factor +++ b/extra/ui/gadgets/slate/slate.factor @@ -3,7 +3,11 @@ USING: kernel namespaces opengl ui.render ui.gadgets ; IN: ui.gadgets.slate -TUPLE: slate action dim graft ungraft ; +TUPLE: slate action dim graft ungraft + button-down + button-up + key-down + key-up ; : ( action -- slate ) slate construct-gadget @@ -19,4 +23,100 @@ M: slate draw-gadget* ( slate -- ) M: slate graft* ( slate -- ) slate-graft call ; -M: slate ungraft* ( slate -- ) slate-ungraft call ; \ No newline at end of file +M: slate ungraft* ( slate -- ) slate-ungraft call ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: key-pressed-value + +: key-pressed? ( -- ? ) key-pressed-value get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: mouse-pressed-value + +: mouse-pressed? ( -- ? ) mouse-pressed-value get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: key-value + +: key ( -- key ) key-value get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: button-value + +: button ( -- val ) button-value get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: combinators ui.gestures accessors ; + +! M: slate handle-gesture* ( gadget gesture delegate -- ? ) +! drop nip +! { +! { +! [ dup key-down? ] +! [ + +! key-down-sym key-value set +! key-pressed-value on +! t +! ] +! } +! { [ dup key-up? ] [ drop key-pressed-value off t ] } +! { +! [ dup button-down? ] +! [ +! button-down-# mouse-button-value set +! mouse-pressed-value on +! t +! ] +! } +! { [ dup button-up? ] [ drop mouse-pressed-value off t ] } +! { [ t ] [ drop t ] } +! } +! cond ; + +M: slate handle-gesture* ( gadget gesture delegate -- ? ) + rot drop swap ! delegate gesture + { + { + [ dup key-down? ] + [ + key-down-sym key-value set + key-pressed-value on + key-down>> dup [ call ] [ drop ] if + t + ] + } + { + [ dup key-up? ] + [ + key-pressed-value off + drop + key-up>> dup [ call ] [ drop ] if + t + ] } + { + [ dup button-down? ] + [ + button-down-# button-value set + mouse-pressed-value on + button-down>> dup [ call ] [ drop ] if + t + ] + } + { + [ dup button-up? ] + [ + mouse-pressed-value off + drop + button-up>> dup [ call ] [ drop ] if + t + ] + } + { [ t ] [ 2drop t ] } + } + cond ; \ No newline at end of file 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/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/process/process.factor b/extra/unix/process/process.factor index fc8103b656..ba02f15c7a 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -9,7 +9,7 @@ IN: unix.process ! io.launcher instead. : >argv ( seq -- alien ) - [ malloc-char-string ] map f add >c-void*-array ; + [ malloc-char-string ] map f suffix >c-void*-array ; : exec ( pathname argv -- int ) [ malloc-char-string ] [ >argv ] bi* execv ; 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/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index 238ff18c39..acd3848f10 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -40,7 +40,7 @@ unless : (parse-com-function) ( tokens -- definition ) [ second ] [ first ] - [ 3 tail 2 group [ first ] map "void*" add* ] + [ 3 tail 2 group [ first ] map "void*" prefix ] tri ; diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index 28237a7b2c..8c74d61656 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -113,7 +113,7 @@ M: regexp text-hash-char drop f ; : rule-chars* ( rule -- string ) dup rule-chars swap rule-start matcher-text - text-hash-char [ add ] when* ; + text-hash-char [ suffix ] when* ; : add-rule ( rule ruleset -- ) >r dup rule-chars* >upper swap 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/extra/ldap/authors.txt b/unmaintained/ldap/authors.txt similarity index 100% rename from extra/ldap/authors.txt rename to unmaintained/ldap/authors.txt diff --git a/extra/ldap/conf/addentry.ldif b/unmaintained/ldap/conf/addentry.ldif similarity index 100% rename from extra/ldap/conf/addentry.ldif rename to unmaintained/ldap/conf/addentry.ldif diff --git a/extra/ldap/conf/createdit.ldif b/unmaintained/ldap/conf/createdit.ldif similarity index 100% rename from extra/ldap/conf/createdit.ldif rename to unmaintained/ldap/conf/createdit.ldif diff --git a/extra/ldap/conf/slapd.conf b/unmaintained/ldap/conf/slapd.conf similarity index 100% rename from extra/ldap/conf/slapd.conf rename to unmaintained/ldap/conf/slapd.conf diff --git a/extra/ldap/ldap-tests.factor b/unmaintained/ldap/ldap-tests.factor similarity index 100% rename from extra/ldap/ldap-tests.factor rename to unmaintained/ldap/ldap-tests.factor diff --git a/extra/ldap/ldap.factor b/unmaintained/ldap/ldap.factor similarity index 100% rename from extra/ldap/ldap.factor rename to unmaintained/ldap/ldap.factor diff --git a/extra/ldap/libldap/authors.txt b/unmaintained/ldap/libldap/authors.txt similarity index 100% rename from extra/ldap/libldap/authors.txt rename to unmaintained/ldap/libldap/authors.txt diff --git a/extra/ldap/libldap/libldap.factor b/unmaintained/ldap/libldap/libldap.factor similarity index 100% rename from extra/ldap/libldap/libldap.factor rename to unmaintained/ldap/libldap/libldap.factor diff --git a/extra/ldap/libldap/tags.txt b/unmaintained/ldap/libldap/tags.txt similarity index 100% rename from extra/ldap/libldap/tags.txt rename to unmaintained/ldap/libldap/tags.txt diff --git a/extra/ldap/summary.txt b/unmaintained/ldap/summary.txt similarity index 100% rename from extra/ldap/summary.txt rename to unmaintained/ldap/summary.txt diff --git a/extra/ldap/tags.txt b/unmaintained/ldap/tags.txt similarity index 100% rename from extra/ldap/tags.txt rename to unmaintained/ldap/tags.txt 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/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);