diff --git a/build-support/grovel.c b/build-support/grovel.c index 2eee054dab..db16aa9bca 100644 --- a/build-support/grovel.c +++ b/build-support/grovel.c @@ -42,6 +42,7 @@ #include #include #include + #include #include #include #endif @@ -146,6 +147,7 @@ void unix_constants() constant(PROT_WRITE); constant(MAP_FILE); constant(MAP_SHARED); + constant(PATH_MAX); grovel(pid_t); } 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 deb54fdeeb..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" = [ os "-" rot 3append ] when ; + cpu word-name + dup "ppc" = [ >r os word-name "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; @@ -55,7 +56,7 @@ IN: bootstrap.image : quot-xt@ 3 bootstrap-cells object tag-number - ; : jit-define ( quot rc rt offset name -- ) - >r >r >r >r { } make r> r> r> 4array r> set ; + >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ; ! The image being constructed; a vector of word-size integers SYMBOL: image @@ -134,10 +135,10 @@ SYMBOL: undefined-quot : here ( -- size ) heap-size data-base + ; -: here-as ( tag -- pointer ) here swap bitor ; +: here-as ( tag -- pointer ) here bitor ; : align-here ( -- ) - here 8 mod 4 = [ heap-size drop 0 emit ] when ; + here 8 mod 4 = [ 0 emit ] when ; : emit-fixnum ( n -- ) tag-fixnum emit ; @@ -164,7 +165,7 @@ GENERIC: ' ( obj -- ptr ) userenv-size [ f ' emit ] times ; : emit-userenv ( symbol -- ) - dup get ' swap userenv-offset fixup ; + [ get ' ] [ userenv-offset ] bi fixup ; ! Bignums @@ -175,14 +176,15 @@ GENERIC: ' ( obj -- ptr ) : bignum>seq ( n -- seq ) #! n is positive or zero. [ dup 0 > ] - [ dup bignum-bits neg shift swap bignum-radix bitand ] + [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ] [ ] unfold nip ; -USE: continuations : emit-bignum ( n -- ) - dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq - dup length 1+ emit-fixnum - swap emit emit-seq ; + dup dup 0 < [ neg ] when bignum>seq + [ nip length 1+ emit-fixnum ] + [ drop 0 < 1 0 ? emit ] + [ nip emit-seq ] + 2tri ; M: bignum ' bignum tag-number dup [ emit-bignum ] emit-object ; @@ -221,28 +223,33 @@ M: f ' ! Words : emit-word ( word -- ) - dup subwords [ emit-word ] each [ - dup hashcode ' , - dup word-name ' , - dup word-vocabulary ' , - dup word-def ' , - dup word-props ' , - f ' , - 0 , ! count - 0 , ! xt - 0 , ! code - 0 , ! profiling - ] { } make - \ word type-number object tag-number - [ emit-seq ] emit-object - swap objects get set-at ; + [ subwords [ emit-word ] each ] + [ + [ + { + [ hashcode , ] + [ word-name , ] + [ word-vocabulary , ] + [ word-def , ] + [ word-props , ] + } cleave + f , + 0 , ! count + 0 , ! xt + 0 , ! code + 0 , ! profiling + ] { } make [ ' ] map + ] bi + \ word type-number object tag-number + [ emit-seq ] emit-object + ] keep objects get set-at ; : word-error ( word msg -- * ) [ % dup word-vocabulary % " " % word-name % ] "" make throw ; : transfer-word ( word -- word ) - dup target-word swap or ; + [ target-word ] keep or ; : fixup-word ( word -- offset ) transfer-word dup objects get at @@ -285,9 +292,10 @@ M: string ' length 0 assert= ; : emit-dummy-array ( obj type -- ptr ) - swap assert-empty - type-number object tag-number - [ 0 emit-fixnum ] emit-object ; + [ assert-empty ] [ + type-number object tag-number + [ 0 emit-fixnum ] emit-object + ] bi* ; M: byte-array ' byte-array emit-dummy-array ; @@ -296,29 +304,28 @@ M: bit-array ' bit-array emit-dummy-array ; M: float-array ' float-array emit-dummy-array ; ! Tuples +: (emit-tuple) ( tuple -- pointer ) + [ tuple>array 1 tail-slice ] + [ class transfer-word tuple-layout ] bi prefix [ ' ] map + tuple type-number dup [ emit-seq ] emit-object ; + : emit-tuple ( tuple -- pointer ) - [ - [ - dup class transfer-word tuple-layout ' , - tuple>array 1 tail-slice [ ' ] map % - ] { } make - tuple type-number dup [ emit-seq ] emit-object - ] - ! Hack - over class word-name "tombstone" = - [ objects get swap cache ] [ call ] if ; + dup class word-name "tombstone" = + [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ; M: tuple ' emit-tuple ; M: tuple-layout ' objects get [ [ - dup layout-hashcode ' , - dup layout-class ' , - dup layout-size ' , - dup layout-superclasses ' , - layout-echelon ' , - ] { } make + { + [ layout-hashcode , ] + [ layout-class , ] + [ layout-size , ] + [ layout-superclasses , ] + [ layout-echelon , ] + } cleave + ] { } make [ ' ] map \ tuple-layout type-number object tag-number [ emit-seq ] emit-object ] cache ; @@ -329,14 +336,9 @@ M: tombstone ' word-def first objects get [ emit-tuple ] cache ; ! Arrays -: emit-array ( list type tag -- pointer ) - >r >r [ ' ] map r> r> [ - dup length emit-fixnum - emit-seq - ] emit-object ; - M: array ' - array type-number object tag-number emit-array ; + [ ' ] map array type-number object tag-number + [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; ! Quotations @@ -351,13 +353,6 @@ M: quotation ' ] emit-object ] cache ; -! Curries - -M: curry ' - dup curry-quot ' swap curry-obj ' - \ curry type-number object tag-number - [ emit emit ] emit-object ; - ! End of the image : emit-words ( -- ) @@ -437,8 +432,8 @@ M: curry ' : write-image ( image -- ) "Writing image to " write architecture get boot-image-name resource-path - dup write "..." print flush - binary [ (write-image) ] with-stream ; + [ write "..." print flush ] + [ binary [ (write-image) ] with-stream ] bi ; PRIVATE> 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 2e1a7f9f57..6c87730278 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -5,7 +5,8 @@ hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes classes.tuple classes.tuple.private kernel.private vocabs vocabs.loader source-files definitions slots.deprecated -classes.union compiler.units bootstrap.image.private io.files ; +classes.union compiler.units bootstrap.image.private io.files +accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -30,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 @@ -100,42 +102,81 @@ 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 dup - \ tag-mask get < \ tag \ type ? , , \ 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 - dup builtin-predicate-quot define-predicate - predicate-word make-inline ; + dup builtin-predicate-quot define-predicate ; : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; : register-builtin ( class -- ) - dup - dup lookup-type-number "type" set-word-prop - dup "type" word-prop builtins get set-nth ; + [ dup lookup-type-number "type" set-word-prop ] + [ dup "type" word-prop builtins get set-nth ] + [ f f builtin-class define-class ] + tri ; : define-builtin-slots ( symbol slotspec -- ) - dupd 1 simple-slots - 2dup "slots" set-word-prop - define-slots ; + [ drop ] [ 1 simple-slots ] 2bi + [ "slots" set-word-prop ] [ define-slots ] 2bi ; : define-builtin ( symbol slotspec -- ) - >r - dup register-builtin - dup f f builtin-class define-class - dup define-builtin-predicate + >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 @@ -324,44 +365,28 @@ define-builtin } } define-builtin -"tuple" "kernel" create { } define-builtin - -"tuple" "kernel" lookup -{ - { - { "object" "kernel" } - "delegate" - { "delegate" "kernel" } - { "set-delegate" "kernel" } - } -} -define-tuple-slots - -"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 @@ -495,8 +520,9 @@ f builtins get num-tags get tail union-class define-class } define-tuple-class "curry" "kernel" lookup -dup f "inline" set-word-prop -dup tuple-layout [ ] curry define +[ f "inline" set-word-prop ] +[ ] +[ tuple-layout [ ] curry ] tri define "compose" "kernel" create "tuple" "kernel" lookup @@ -515,8 +541,9 @@ dup tuple-layout [ ] curry define } define-tuple-class "compose" "kernel" lookup -dup f "inline" set-word-prop -dup tuple-layout [ ] curry define +[ f "inline" set-word-prop ] +[ ] +[ tuple-layout [ ] curry ] tri define ! Primitive words : make-primitive ( word vocab n -- ) @@ -629,7 +656,6 @@ dup tuple-layout [ ] curry define { "code-room" "memory" } { "os-env" "system" } { "millis" "system" } - { "type" "kernel.private" } { "tag" "kernel.private" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } @@ -701,7 +727,6 @@ dup tuple-layout [ ] curry define { "(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 7123d5c7c8..664f0545fa 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -153,26 +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: permutation -{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } } -{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ; - -HELP: reshape-tuple -{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } } -{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ; - -HELP: reshape-tuples -{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } } -{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ; - -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-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 9b8228155b..a8e9066f56 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs namespaces quotations sequences.private classes continuations generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra -calendar prettyprint io.streams.string splitting ; +calendar prettyprint io.streams.string splitting inspector ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -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 @@ -265,9 +265,13 @@ C: laptop [ t ] [ "laptop" get computer? ] unit-test [ t ] [ "laptop" get tuple? ] unit-test -[ "Pentium" ] [ "laptop" get cpu>> ] unit-test -[ 128 ] [ "laptop" get ram>> ] unit-test -[ t ] [ "laptop" get battery>> 3 hours = ] unit-test +: test-laptop-slot-values + [ laptop ] [ "laptop" get class ] unit-test + [ "Pentium" ] [ "laptop" get cpu>> ] unit-test + [ 128 ] [ "laptop" get ram>> ] unit-test + [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ; + +test-laptop-slot-values [ laptop ] [ "laptop" get tuple-layout @@ -294,9 +298,13 @@ C: server [ t ] [ "server" get computer? ] unit-test [ t ] [ "server" get tuple? ] unit-test -[ "PowerPC" ] [ "server" get cpu>> ] unit-test -[ 64 ] [ "server" get ram>> ] unit-test -[ "1U" ] [ "server" get rackmount>> ] unit-test +: test-server-slot-values + [ server ] [ "server" get class ] unit-test + [ "PowerPC" ] [ "server" get cpu>> ] unit-test + [ 64 ] [ "server" get ram>> ] unit-test + [ "1U" ] [ "server" get rackmount>> ] unit-test ; + +test-server-slot-values [ f ] [ "server" get laptop? ] unit-test [ f ] [ "laptop" get server? ] unit-test @@ -316,10 +324,10 @@ C: server "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval ] must-fail -! Reshaping with inheritance +! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test [ f ] [ electronic-device laptop class< ] unit-test [ t ] [ server electronic-device class< ] unit-test @@ -335,11 +343,125 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +TUPLE: make-me-some-accessors voltage grounded? ; + +[ f ] [ "laptop" get voltage>> ] unit-test +[ f ] [ "server" get voltage>> ] unit-test + +[ ] [ "laptop" get 220 >>voltage drop ] unit-test +[ ] [ "server" get 110 >>voltage drop ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +[ 220 ] [ "laptop" get voltage>> ] unit-test +[ 110 ] [ "server" get voltage>> ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +[ 220 ] [ "laptop" get voltage>> ] unit-test +[ 110 ] [ "server" get voltage>> ] unit-test + +! Reshaping superclass and subclass simultaneously +"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval + +test-laptop-slot-values +test-server-slot-values + +[ 220 ] [ "laptop" get voltage>> ] unit-test +[ 110 ] [ "server" get voltage>> ] unit-test + +! Reshape crash +TUPLE: test1 a ; TUPLE: test2 < test1 b ; + +C: test2 + +"a" "b" "test" set + +: test-a/b + [ "a" ] [ "test" get a>> ] unit-test + [ "b" ] [ "test" get b>> ] unit-test ; + +test-a/b + +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test + +test-a/b + +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test + +test-a/b + +! Twice in the same compilation unit +[ + test1 tuple { "a" "x" "y" } define-tuple-class + test1 tuple { "a" "y" } define-tuple-class +] with-compilation-unit + +test-a/b + +! Moving slots up and down +TUPLE: move-up-1 a b ; +TUPLE: move-up-2 < move-up-1 c ; + +T{ move-up-2 f "a" "b" "c" } "move-up" set + +: test-move-up + [ "a" ] [ "move-up" get a>> ] unit-test + [ "b" ] [ "move-up" get b>> ] unit-test + [ "c" ] [ "move-up" get c>> ] unit-test ; + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test + +! Constructors must be recompiled when changing superclass +TUPLE: constructor-update-1 xxx ; + +TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ; + +C: constructor-update-2 + +{ 3 1 } [ ] must-infer-as + +[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test + +{ 5 1 } [ ] must-infer-as + +[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 tuple-slots ] unit-test + ! Redefinition problem TUPLE: redefinition-problem ; @@ -389,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 a452d0eeec..b1cb3f8a66 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -19,12 +19,20 @@ 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 ; +M: tuple-layout tuple-layout ; + : tuple-size tuple-layout layout-size ; inline +: prepare-tuple>array ( tuple -- n tuple layout ) + [ tuple-size ] [ ] [ tuple-layout ] tri ; + +: copy-tuple-slots ( n tuple -- array ) + [ array-nth ] curry map ; + PRIVATE> : check-tuple ( class -- ) @@ -32,28 +40,31 @@ PRIVATE> [ drop ] [ no-tuple-class ] if ; : tuple>array ( tuple -- array ) - dup tuple-layout - [ layout-size swap [ array-nth ] curry map ] keep - layout-class add* ; + prepare-tuple>array + >r copy-tuple-slots r> + layout-class prefix ; -: >tuple ( seq -- tuple ) - dup first tuple-layout [ - >r 1 tail-slice dup length r> - [ tuple-size min ] keep - [ set-array-nth ] curry - 2each +: tuple-slots ( tuple -- array ) + prepare-tuple>array drop copy-tuple-slots ; + +: slots>tuple ( tuple class -- array ) + tuple-layout [ + [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each ] keep ; +: >tuple ( tuple -- array ) + unclip slots>tuple ; + : slot-names ( class -- seq ) - "slots" word-prop [ name>> ] map ; + "slot-names" word-prop ; r over r> array-nth >r array-nth r> = ] 2curry - all-integers? + 2dup [ tuple-layout ] bi@ eq? [ + [ drop tuple-size ] + [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ] + 2bi all-integers? ] [ 2drop f ] if ; @@ -92,72 +103,87 @@ PRIVATE> superclasses 1 head-slice* [ slot-names length ] map sum ; -: generate-tuple-slots ( class slots -- slots ) +: generate-tuple-slots ( class slots -- slot-specs ) over superclass-size 2 + simple-slots ; -: define-tuple-slots ( class slots -- ) - dupd generate-tuple-slots +: define-tuple-slots ( class -- ) + dup dup slot-names generate-tuple-slots [ "slots" set-word-prop ] - [ define-accessors ] - [ define-slots ] 2tri ; + [ define-accessors ] ! new + [ define-slots ] ! old + 2tri ; : make-tuple-layout ( class -- layout ) [ ] - [ [ superclass-size ] [ "slots" word-prop length ] bi + ] + [ [ superclass-size ] [ slot-names length ] bi + ] [ superclasses dup length 1- ] tri ; : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: removed-slots ( class newslots -- seq ) - swap slot-names seq-diff ; +: all-slot-names ( class -- slots ) + superclasses [ slot-names ] map concat \ class prefix ; -: forget-slots ( class slots -- ) - dupd removed-slots [ - [ reader-word forget-method ] - [ writer-word forget-method ] 2bi - ] with each ; +: compute-slot-permutation ( class old-slot-names -- permutation ) + >r all-slot-names r> [ index ] curry map ; -: permutation ( seq1 seq2 -- permutation ) - swap [ index ] curry map ; +: apply-slot-permutation ( old-values permutation -- new-values ) + [ [ swap ?nth ] [ drop f ] if* ] with map ; -: reshape-tuple ( oldtuple permutation -- newtuple ) - >r tuple>array 2 cut r> - [ [ swap ?nth ] [ drop f ] if* ] with map - append >tuple ; +: permute-slots ( old-values -- new-values ) + dup first dup outdated-tuples get at + compute-slot-permutation + apply-slot-permutation ; -: reshape-tuples ( class superclass newslots -- ) - nip - >r dup slot-names r> permutation - [ - >r "predicate" word-prop instances dup - r> [ reshape-tuple ] curry map - become - ] 2curry after-compilation ; +: change-tuple ( tuple quot -- newtuple ) + >r tuple>array r> call >tuple ; inline + +: update-tuple ( tuple -- newtuple ) + [ permute-slots ] change-tuple ; + +: update-tuples ( -- ) + outdated-tuples get + dup assoc-empty? [ drop ] [ + [ >r class r> key? ] curry instances + dup [ update-tuple ] map become + ] if ; + +[ update-tuples ] update-tuples-hook set-global + +: update-tuples-after ( class -- ) + outdated-tuples get [ all-slot-names ] cache drop ; + +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 define-tuple-slots ] [ - 2drop - class-usages keys [ tuple-class? ] subset [ - [ define-tuple-layout ] - [ define-tuple-predicate ] - bi - ] each - ] 3tri ; + [ nip "slot-names" set-word-prop ] + [ 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 -- ) - [ reshape-tuples ] [ - nip - [ forget-slots ] - [ drop changed-word ] - [ drop redefined ] - 2tri + 2drop + [ + [ update-tuples-after ] + [ changed-word ] + [ redefined ] + tri + ] each-subclass ] [ define-new-tuple-class ] - 3tri ; + 3bi ; : tuple-class-unchanged? ( class superclass slots -- ? ) rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; @@ -175,20 +201,31 @@ M: tuple-class define-tuple-class 3drop ; : define-error-class ( class superclass slots -- ) - pick >r define-tuple-class r> + [ 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 ; M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; -: delegates ( obj -- seq ) - [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; - -: is? ( obj quot -- ? ) >r delegates r> contains? ; inline - M: tuple hashcode* [ dup tuple-size -rot 0 -rot [ @@ -196,23 +233,13 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -: tuple-slots ( tuple -- seq ) tuple>array 2 tail ; - -! Definition protocol -M: tuple-class reset-class - { "metaclass" "superclass" "slots" "layout" } reset-props ; - +! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; M: object set-slots ( ... obj slots -- ) get-slots ; -M: object construct-empty ( class -- tuple ) - tuple-layout ; +: delegates ( obj -- seq ) [ delegate ] follow ; -M: object construct ( ... slots class -- tuple ) - construct-empty [ swap set-slots ] keep ; - -M: object construct-boa ( ... class -- tuple ) - tuple-layout ; +: 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/compiler/units/units.factor b/core/compiler/units/units.factor index 9849ddca7d..f87c1ec985 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- ) dup [ drop crossref? ] assoc-contains? modify-code-heap ; -SYMBOL: post-compile-tasks - -: after-compilation ( quot -- ) - post-compile-tasks get push ; +SYMBOL: outdated-tuples +SYMBOL: update-tuples-hook : call-recompile-hook ( -- ) changed-words get keys compiled-usages recompile-hook get call ; -: call-post-compile-tasks ( -- ) - post-compile-tasks get [ call ] each ; +: call-update-tuples-hook ( -- ) + update-tuples-hook get call ; : finish-compilation-unit ( -- ) call-recompile-hook - call-post-compile-tasks + call-update-tuples-hook dup [ drop crossref? ] assoc-contains? modify-code-heap changed-definitions notify-definition-observers ; @@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks [ H{ } clone changed-words set H{ } clone forgotten-definitions set - V{ } clone post-compile-tasks set + H{ } clone outdated-tuples set new-definitions set old-definitions set [ finish-compilation-unit ] diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7209b7ec4d..ca7af930f2 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -29,6 +29,7 @@ $nl { $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } +{ $subsection "debugger" } { $subsection "errors-post-mortem" } "When Factor encouters a critical error, it calls the following word:" { $subsection die } ; 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/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index 5e8b6df34a..ca6aa59cc4 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -1,6 +1,7 @@ USING: alien arrays generic generic.math help.markup help.syntax kernel math memory strings sbufs vectors io io.files classes -help generic.standard continuations system debugger.private ; +help generic.standard continuations system debugger.private +io.files.private ; IN: debugger ARTICLE: "errors-assert" "Assertions" @@ -86,7 +87,15 @@ HELP: error-hook HELP: try { $values { "quot" "a quotation" } } -{ $description "Calls the quotation. If it throws an error, calls " { $link error-hook } " with the error and restores the data stack." } ; +{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." } +{ $examples + "The following example prints an error and keeps going:" + { $code + "[ \"error\" throw ] try" + "\"still running...\" print" + } + { $link "listener" } " uses " { $link try } " to recover from user errors." +} ; HELP: expired-error. { $error-description "Thrown by " { $link alien-address } " and " { $link alien-invoke } " if an " { $link alien } " object passed in as a parameter has expired. Alien objects expire if they are saved an image which is subsequently loaded; this prevents a certain class of programming errors, usually attempts to use uninitialized objects, since holding a C address is meaningless between sessions." } 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..85e17ded46 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -28,11 +28,14 @@ ARTICLE: "pathnames" "Pathname manipulation" { $subsection } ; ARTICLE: "directories" "Directories" -"Current and home directories:" +"Current directory:" +{ $subsection with-directory } +{ $subsection current-directory } +"Home directory:" +{ $subsection home } +"Current system directory:" { $subsection cwd } { $subsection cd } -{ $subsection with-directory } -{ $subsection home } "Directory listing:" { $subsection directory } { $subsection directory* } @@ -197,19 +200,20 @@ HELP: file-contents HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; +{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } +{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ; HELP: cd { $values { "path" "a pathname string" } } { $description "Changes the current working directory of the Factor process." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; +{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } +{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ; -{ cd cwd with-directory } related-words +{ cd cwd current-directory with-directory } related-words HELP: with-directory { $values { "path" "a pathname string" } { "quot" quotation } } -{ $description "Changes the current working directory for the duration of a quotation's execution." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; +{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ; HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } @@ -252,7 +256,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 48098e612d..08ec78492a 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,7 +3,7 @@ USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs continuations io.encodings -io.encodings.binary init ; +io.encodings.binary init accessors ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -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 @@ -145,8 +149,17 @@ PRIVATE> TUPLE: file-info type size permissions modified ; HOOK: file-info io-backend ( path -- info ) + +! Symlinks HOOK: link-info io-backend ( path -- info ) +HOOK: make-link io-backend ( path1 path2 -- ) + +HOOK: read-link io-backend ( path -- info ) + +: copy-link ( path1 path2 -- ) + >r read-link r> make-link ; + SYMBOL: +regular-file+ SYMBOL: +directory+ SYMBOL: +character-device+ @@ -158,34 +171,52 @@ SYMBOL: +unknown+ ! File metadata : exists? ( path -- ? ) - normalize-pathname (exists?) ; + normalize-path (exists?) ; : directory? ( path -- ? ) file-info file-info-type +directory+ = ; -! Current working directory + + +SYMBOL: current-directory + [ cwd current-directory set-global ] "io.files" add-init-hook +: resource-path ( path -- newpath ) + "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? ] [ ] } @@ -218,14 +249,14 @@ HOOK: delete-file io-backend ( path -- ) HOOK: delete-directory io-backend ( path -- ) -: (delete-tree) ( path dir? -- ) - [ - dup directory* [ (delete-tree) ] assoc-each - delete-directory - ] [ delete-file ] if ; - : delete-tree ( path -- ) - dup directory? (delete-tree) ; + dup link-info type>> +directory+ = [ + dup directory over [ + [ first delete-tree ] each + ] with-directory delete-directory + ] [ + delete-file + ] if ; : to-directory over file-name append-path ; @@ -258,13 +289,17 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) - over directory? [ - >r dup directory swap r> [ - >r swap first append-path r> copy-tree-into - ] 2curry each - ] [ - copy-file - ] if ; + normalize-path + over link-info type>> + { + { +symbolic-link+ [ copy-link ] } + { +directory+ [ + >r dup directory r> rot [ + [ >r first r> copy-tree-into ] curry each + ] with-directory + ] } + [ drop copy-file ] + } case ; : copy-tree-into ( from to -- ) to-directory copy-tree ; @@ -273,9 +308,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 ; @@ -283,14 +315,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 ; @@ -301,7 +325,7 @@ M: pathname <=> [ pathname-string ] compare ; ! Home directory : home ( -- dir ) { - { [ winnt? ] [ "USERPROFILE" os-env ] } - { [ wince? ] [ "" resource-path ] } - { [ unix? ] [ "HOME" os-env ] } + { [ os winnt? ] [ "USERPROFILE" os-env ] } + { [ os wince? ] [ "" resource-path ] } + { [ os unix? ] [ "HOME" os-env ] } } cond ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index a446869096..53618d4628 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -7,6 +7,8 @@ IN: kernel ARTICLE: "shuffle-words" "Shuffle words" "Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions." $nl +"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "." +$nl "Removing stack elements:" { $subsection drop } { $subsection 2drop } @@ -39,9 +41,28 @@ $nl { $code ": foo ( m ? n -- m+n/n )" " >r [ r> + ] [ drop r> ] if ; ! This is OK" -} -"An alternative to using " { $link >r } " and " { $link r> } " is the following:" -{ $subsection dip } ; +} ; + +ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" +"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." +$nl +"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" +{ $code + ": keep [ ] bi ;" + ": 2keep [ ] 2bi ;" + ": 3keep [ ] 3bi ;" + "" + ": dup [ ] [ ] bi ;" + ": 2dup [ ] [ ] 2bi ;" + ": 3dup [ ] [ ] 3bi ;" + "" + ": tuck [ nip ] [ ] 2bi ;" + ": swap [ nip ] [ drop ] 2bi ;" + "" + ": over [ ] [ drop ] 2bi ;" + ": pick [ ] [ 2drop ] 3bi ;" + ": 2over [ ] [ drop ] 3bi ;" +} ; ARTICLE: "cleave-combinators" "Cleave combinators" "The cleave combinators apply multiple quotations to a single value." @@ -49,9 +70,11 @@ $nl "Two quotations:" { $subsection bi } { $subsection 2bi } +{ $subsection 3bi } "Three quotations:" { $subsection tri } { $subsection 2tri } +{ $subsection 3tri } "Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" { $code "! First alternative; uses keep" @@ -66,13 +89,38 @@ $nl "The latter is more aesthetically pleasing than the former." $nl "A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "cleave-shuffle-equivalence" } ; + +ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" +"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "." $nl -"From the Merriam-Webster Dictionary: " -$nl -{ $strong "cleave" } -{ $list - { $emphasis "To divide by or as if by a cutting blow" } - { $emphasis "To separate into distinct parts and especially into groups having divergent views" } +"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" +{ $code + ": dip [ ] bi* ;" + "" + ": slip [ call ] [ ] bi* ;" + ": 2slip [ call ] [ ] [ ] tri* ;" + "" + ": nip [ drop ] [ ] bi* ;" + ": 2nip [ drop ] [ drop ] [ ] tri* ;" + "" + ": rot" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" + "" + ": -rot" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " 3tri ;" + "" + ": spin" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" } ; ARTICLE: "spread-combinators" "Spread combinators" @@ -96,7 +144,8 @@ $nl } $nl -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ; +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "spread-shuffle-equivalence" } ; ARTICLE: "apply-combinators" "Apply combinators" "The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application." @@ -201,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 } @@ -328,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" } @@ -364,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" } "." } ; @@ -496,7 +543,7 @@ HELP: 2bi "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- z )" } ", then the following two lines are equivalent:" { $code "[ p ] [ q ] 2bi" - "2dup p swap q" + "2dup p -rot q" } "In general, the following two lines are equivalent:" { $code @@ -505,6 +552,27 @@ HELP: 2bi } } ; +HELP: 3bi +{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." } +{ $examples + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] 3bi" + "3dup p q" + } + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] 3bi" + "3dup p -roll q" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] 3bi" + "[ p ] 3keep q" + } +} ; + HELP: tri { $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } } { $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." } @@ -542,6 +610,22 @@ HELP: 2tri } } ; +HELP: 3tri +{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." } +{ $examples + "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 3tri" + "3dup p 3dup q r" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 3tri" + "[ p ] 3keep [ q ] 3keep r" + } +} ; + HELP: bi* { $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } } @@ -585,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@ @@ -596,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@ @@ -607,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 -- ) @@ -705,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 dfd5c1b32a..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 ) [ @@ -23,9 +23,6 @@ C: slot-spec [ drop ] [ 1array , \ declare , ] if ] [ ] make ; -: slot-named ( name specs -- spec/f ) - [ slot-spec-name = ] with find nip ; - : create-accessor ( name effect -- word ) >r "accessors" create dup r> "declared-effect" set-word-prop ; @@ -82,3 +79,6 @@ C: slot-spec dup slot-spec-offset swap slot-spec-name define-slot-methods ] with each ; + +: slot-named ( name specs -- spec/f ) + [ slot-spec-name = ] with find nip ; 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 461d951209..ece6d64ed9 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -48,15 +48,31 @@ IN: builder : record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ; -: do-make-clean ( -- ) { "make" "clean" } try-process ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gnu-make ( -- string ) + os { "freebsd" "openbsd" "netbsd" } member? + [ "gmake" ] + [ "make" ] + if ; + +! : do-make-clean ( -- ) { "make" "clean" } try-process ; + +: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! : make-vm ( -- desc ) +! +! { "make" } >>command +! "../compile-log" >>stdout +! +stdout+ >>stderr ; + : make-vm ( -- desc ) - { "make" } >>command - "../compile-log" >>stdout - +stdout+ >>stderr ; + { gnu-make } to-strings >>command + "../compile-log" >>stdout + +stdout+ >>stderr ; : do-make-vm ( -- ) make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; @@ -229,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/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor index 55da97202f..4a070190e3 100644 --- a/extra/crypto/barrett/barrett.factor +++ b/extra/crypto/barrett/barrett.factor @@ -4,5 +4,11 @@ IN: crypto.barrett : barrett-mu ( n size -- mu ) #! Calculates Barrett's reduction parameter mu #! size = word size in bits (8, 16, 32, 64, ...) - over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ; + ! over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ; + [ + [ log2 1+ ] [ / 2 * ] bi* + ] [ + 2^ rot ^ swap /i + ] 2bi ; + diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor index b53ecaac3c..559c7934d0 100644 --- a/extra/crypto/common/common-docs.factor +++ b/extra/crypto/common/common-docs.factor @@ -2,23 +2,6 @@ USING: help.markup help.syntax kernel math sequences quotations math.private ; IN: crypto.common -HELP: >32-bit -{ $values { "x" integer } { "y" integer } } -{ $description "Used to implement 32-bit integer overflow." } ; - -HELP: >64-bit -{ $values { "x" integer } { "y" integer } } -{ $description "Used to implement 64-bit integer overflow." } ; - -HELP: bitroll -{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } -{ $description "Roll n by s bits to the left, wrapping around after w bits." } -{ $examples - { $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } - { $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } -} ; - - HELP: hex-string { $values { "seq" "a sequence" } { "str" "a string" } } { $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." } diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index 3ac551d114..a714727ad9 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -1,11 +1,8 @@ USING: arrays kernel io io.binary sbufs splitting strings sequences -namespaces math math.parser parser hints ; +namespaces math math.parser parser hints math.bitfields.lib ; IN: crypto.common -: >32-bit ( x -- y ) HEX: ffffffff bitand ; inline -: >64-bit ( x -- y ) HEX: ffffffffffffffff bitand ; inline - -: w+ ( int int -- int ) + >32-bit ; inline +: w+ ( int int -- int ) + 32 bits ; inline : (nth-int) ( string n -- int ) 2 shift dup 4 + rot ; inline @@ -39,26 +36,9 @@ SYMBOL: big-endian? 3 shift 8 rot [ >be ] [ >le ] if % ] "" make 64 group ; -: shift-mod ( n s w -- n ) - >r shift r> 2^ 1- bitand ; inline - : update-old-new ( old new -- ) [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline -: bitroll ( x s w -- y ) - [ 1 - bitand ] keep - over 0 < [ [ + ] keep ] when - [ shift-mod ] 3keep - [ - ] keep shift-mod bitor ; inline - -: bitroll-32 ( n s -- n' ) 32 bitroll ; - -HINTS: bitroll-32 bignum fixnum ; - -: bitroll-64 ( n s -- n' ) 64 bitroll ; - -HINTS: bitroll-64 bignum fixnum ; - : hex-string ( seq -- str ) [ [ >hex 2 48 pad-left % ] each ] "" make ; @@ -70,9 +50,8 @@ HINTS: bitroll-64 bignum fixnum ; : 2seq>seq ( seq1 seq2 -- seq ) #! { aceg } { bdfh } -> { abcdefgh } - swap ! error? [ 2array flip concat ] keep like ; : mod-nth ( n seq -- elt ) #! 5 "abcd" -> b - [ length mod ] keep nth ; + [ length mod ] [ nth ] bi ; diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index fa0cbef4c7..eff95bbcd6 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -9,4 +9,3 @@ IN: crypto.hmac.tests [ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test [ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test [ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test - diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 3dad01fe3a..91d404aead 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -37,7 +37,6 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : byte-array>sha1-hmac ( K string -- hmac ) binary stream>sha1-hmac ; - : stream>md5-hmac ( K stream -- hmac ) [ init-hmac md5-hmac ] with-stream ; diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index 7ecbd767b9..45e10da74d 100755 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -3,7 +3,7 @@ USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting strings sequences crypto.common byte-arrays locals sequences.private -io.encodings.binary symbols ; +io.encodings.binary symbols math.bitfields.lib ; IN: crypto.md5 r bitand r> bitor ; + pick bitnot bitand [ bitand ] [ bitor ] bi* ; : G ( X Y Z -- GXYZ ) #! G(X,Y,Z) = XZ v Y not(Z) - dup bitnot rot bitand >r bitand r> bitor ; + dup bitnot rot bitand [ bitand ] [ bitor ] bi* ; : H ( X Y Z -- HXYZ ) #! H(X,Y,Z) = X xor Y xor Z diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index ccf17da4e8..5d3228db10 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -1,5 +1,5 @@ USING: math.miller-rabin kernel math math.functions namespaces -sequences ; +sequences accessors ; IN: crypto.rsa ! The private key is the only secret. @@ -39,7 +39,7 @@ PRIVATE> public-key ; : rsa-encrypt ( message rsa -- encrypted ) - [ rsa-public-key ] keep rsa-modulus ^mod ; + [ public-key>> ] [ modulus>> ] bi ^mod ; : rsa-decrypt ( encrypted rsa -- message ) - [ rsa-private-key ] keep rsa-modulus ^mod ; \ No newline at end of file + [ private-key>> ] [ modulus>> ] bi ^mod ; diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 8f3d3e6ecc..d054eda31b 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,7 +1,7 @@ USING: arrays combinators crypto.common kernel io io.encodings.binary io.files io.streams.byte-array math.vectors strings sequences namespaces math parser sequences vectors -io.binary hashtables symbols ; +io.binary hashtables symbols math.bitfields.lib ; IN: crypto.sha1 ! Implemented according to RFC 3174. @@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; K get nth , A get 5 bitroll-32 , E get , - ] { } make sum >32-bit ; inline + ] { } make sum 32 bits ; inline : set-vars ( temp -- ) ! E = D; D = C; C = S^30(B); B = A; A = TEMP; diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor index daba6d29ff..0acc5c1388 100755 --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -1,19 +1,19 @@ USING: crypto.common kernel splitting math sequences namespaces -io.binary symbols ; +io.binary symbols math.bitfields.lib ; IN: crypto.sha2 word ; +SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; -: a 0 ; -: b 1 ; -: c 2 ; -: d 3 ; -: e 4 ; -: f 5 ; -: g 6 ; -: h 7 ; +: a 0 ; inline +: b 1 ; inline +: c 2 ; inline +: d 3 ; inline +: e 4 ; inline +: f 5 ; inline +: g 6 ; inline +: h 7 ; inline : initial-H-256 ( -- seq ) { @@ -124,7 +124,6 @@ PRIVATE> initial-H-256 H set 4 word-size set 64 block-size set - \ >32-bit >word set byte-array>sha2 ] with-scope ; diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor index da2603d92c..a17d65d90b 100644 --- a/extra/crypto/timing/timing.factor +++ b/extra/crypto/timing/timing.factor @@ -1,7 +1,6 @@ USING: kernel math threads system ; IN: crypto.timing -: with-timing ( ... quot n -- ) +: with-timing ( quot n -- ) #! force the quotation to execute in, at minimum, n milliseconds - millis 2slip millis - + sleep ; - + millis 2slip millis - + sleep ; inline diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor index 0713e19843..247387ebdf 100644 --- a/extra/crypto/xor/xor.factor +++ b/extra/crypto/xor/xor.factor @@ -1,8 +1,8 @@ USING: crypto.common kernel math sequences ; IN: crypto.xor -TUPLE: no-xor-key ; +ERROR: no-xor-key ; -: xor-crypt ( key seq -- seq ) - over empty? [ no-xor-key construct-empty throw ] when +: xor-crypt ( key seq -- seq' ) + over empty? [ no-xor-key ] when dup length rot [ mod-nth bitxor ] curry 2map ; diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor index 845381a23c..c047393c99 100644 --- a/extra/db/mysql/ffi/ffi.factor +++ b/extra/db/mysql/ffi/ffi.factor @@ -6,9 +6,9 @@ USING: alien alien.syntax combinators kernel system ; IN: db.mysql.ffi << "mysql" { - { [ win32? ] [ "libmySQL.dll" "stdcall" ] } - { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } - { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } + { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] } + { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } + { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] } } cond add-library >> LIBRARY: mysql diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index be491b8c85..7925989bf5 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -5,9 +5,9 @@ USING: alien alien.syntax combinators system ; IN: db.postgresql.ffi << "postgresql" { - { [ win32? ] [ "libpq.dll" ] } - { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } - { [ unix? ] [ "libpq.so" ] } + { [ os winnt? ] [ "libpq.dll" ] } + { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } + { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> ! ConnSatusType diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 1d356b1592..c724025874 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -7,9 +7,9 @@ USING: alien compiler kernel math namespaces sequences strings alien.syntax IN: db.sqlite.ffi << "sqlite" { - { [ winnt? ] [ "sqlite3.dll" ] } - { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } - { [ unix? ] [ "libsqlite3.so" ] } + { [ os winnt? ] [ "sqlite3.dll" ] } + { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } + { [ os unix? ] [ "libsqlite3.so" ] } } cond "cdecl" add-library >> ! Return values from sqlite functions diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 3c73a933e9..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 ) @@ -131,25 +131,17 @@ TUPLE: no-sql-modifier ; HOOK: bind% db ( spec -- ) -TUPLE: no-slot-named ; -: no-slot-named ( -- * ) T{ no-slot-named } throw ; - -: slot-spec-named ( str class -- slot-spec ) - "slots" word-prop [ slot-spec-name = ] with find nip - [ no-slot-named ] unless* ; - : offset-of-slot ( str obj -- n ) - class slot-spec-named slot-spec-offset ; + class "slots" word-prop slot-named slot-spec-offset ; -: get-slot-named ( str obj -- value ) - tuck offset-of-slot [ no-slot-named ] unless* slot ; +: get-slot-named ( name obj -- value ) + tuck offset-of-slot slot ; -: set-slot-named ( value str obj -- ) - tuck offset-of-slot [ no-slot-named ] unless* set-slot ; +: set-slot-named ( value name obj -- ) + tuck offset-of-slot set-slot ; : tuple>filled-slots ( tuple -- alist ) - dup mirror-slots [ slot-spec-name ] map - swap tuple-slots 2array flip [ nip ] assoc-subset ; + [ nip ] assoc-subset ; : tuple>params ( specs tuple -- obj ) [ diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 8ca99ec565..fc62c290df 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -28,7 +28,7 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add >r swap create-method-in r> define ; + pick suffix >r swap create-method r> define ; : 3bi ( x y z p q -- p(x,y,z) q(x,y,z) ) >r 3keep r> call ; inline 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/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index 92320addef..e4f19781ef 100755 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -4,7 +4,7 @@ USING: arrays definitions io kernel math namespaces parser prettyprint sequences strings words editors io.files io.sockets io.streams.byte-array io.binary math.parser io.encodings.ascii io.encodings.binary -io.encodings.utf8 ; +io.encodings.utf8 io.files.private ; IN: editors.jedit : jedit-server-info ( -- port auth ) diff --git a/extra/editors/textwrangler/authors.txt b/extra/editors/textwrangler/authors.txt new file mode 100644 index 0000000000..b4a113da41 --- /dev/null +++ b/extra/editors/textwrangler/authors.txt @@ -0,0 +1 @@ +Ben Schlingelhof diff --git a/extra/editors/textwrangler/summary.txt b/extra/editors/textwrangler/summary.txt new file mode 100644 index 0000000000..cf502f96e5 --- /dev/null +++ b/extra/editors/textwrangler/summary.txt @@ -0,0 +1 @@ +Textwrangler editor integration diff --git a/extra/editors/textwrangler/textwrangler.factor b/extra/editors/textwrangler/textwrangler.factor new file mode 100644 index 0000000000..e97dadcdcb --- /dev/null +++ b/extra/editors/textwrangler/textwrangler.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Ben Schlingelhof. +! See http://factorcode.org/license.txt for BSD license. +USING: definitions io.launcher kernel parser words sequences +math math.parser namespaces editors ; +IN: editors.textwrangler + +: tw ( file line -- ) + [ "edit +" % # " " % % ] "" make run-process drop ; + +: tw-word ( word -- ) + where first2 tw ; + +[ tw ] edit-hook set-global diff --git a/extra/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/backend/backend.factor b/extra/hardware-info/backend/backend.factor index 17794c196d..95a56da2d2 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -1,8 +1,7 @@ +USING: system ; IN: hardware-info.backend -SYMBOL: os HOOK: cpus os ( -- n ) - HOOK: memory-load os ( -- n ) HOOK: physical-mem os ( -- n ) HOOK: available-mem os ( -- n ) diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 69b8678749..6d27cf5252 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -1,16 +1,21 @@ -USING: alien.syntax kernel math prettyprint +USING: alien.syntax kernel math prettyprint io math.parser combinators vocabs.loader hardware-info.backend system ; IN: hardware-info -: kb. ( x -- ) 10 2^ /f . ; -: megs. ( x -- ) 20 2^ /f . ; -: gigs. ( x -- ) 30 2^ /f . ; +: write-unit ( x n str -- ) + [ 2^ /i number>string write bl ] [ write ] bi* ; -<< -{ - { [ windows? ] [ "hardware-info.windows" ] } - { [ linux? ] [ "hardware-info.linux" ] } - { [ macosx? ] [ "hardware-info.macosx" ] } +: kb ( x -- ) 10 "kB" write-unit ; +: megs ( x -- ) 20 "MB" write-unit ; +: gigs ( x -- ) 30 "GB" write-unit ; + +<< { + { [ os windows? ] [ "hardware-info.windows" ] } + { [ os linux? ] [ "hardware-info.linux" ] } + { [ os macosx? ] [ "hardware-info.macosx" ] } { [ t ] [ f ] } } cond [ require ] when* >> +: hardware-report. ( -- ) + "CPUs: " write cpus number>string write nl + "Physical RAM: " write physical-mem megs nl ; diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor index c246a95186..dac052a1de 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/hardware-info/macosx/macosx.factor @@ -1,10 +1,8 @@ USING: alien alien.c-types alien.syntax byte-arrays kernel -namespaces sequences unix hardware-info.backend ; +namespaces sequences unix hardware-info.backend system +io.unix.backend ; IN: hardware-info.macosx -TUPLE: macosx ; -T{ macosx } os set-global - ! See /usr/include/sys/sysctl.h for constants LIBRARY: libc @@ -14,14 +12,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi [ ] map concat ; : (sysctl-query) ( name namelen oldp oldlenp -- oldp error/f ) - over >r - f 0 sysctl -1 = [ err_no strerror ] [ f ] if - r> swap ; + over >r f 0 sysctl io-error r> ; : sysctl-query ( seq n -- byte-array ) - >r [ make-int-array ] keep length r> - [ ] keep - (sysctl-query) [ throw ] when* ; + >r [ make-int-array ] [ length ] bi r> + [ ] [ ] bi (sysctl-query) ; : sysctl-query-string ( seq -- n ) 4096 sysctl-query alien>char-string ; @@ -36,8 +31,15 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi : model ( -- str ) { 6 2 } sysctl-query-string ; M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ; : byte-order ( -- n ) { 6 4 } sysctl-query-uint ; -: user-mem ( -- n ) { 6 4 } sysctl-query-uint ; +M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ; +: user-mem ( -- n ) { 6 6 } sysctl-query-uint ; : page-size ( -- n ) { 6 7 } sysctl-query-uint ; +: disknames ( -- n ) { 6 8 } 8 sysctl-query ; +: diskstats ( -- n ) { 6 9 } 8 sysctl-query ; +: epoch ( -- n ) { 6 10 } sysctl-query-uint ; +: floating-point ( -- n ) { 6 11 } sysctl-query-uint ; +: machine-arch ( -- n ) { 6 12 } sysctl-query-string ; +: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ; : bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ; : cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ; : cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ; @@ -47,7 +49,7 @@ M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ; : l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ; : l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ; : l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ; -: bus-frequency2 ( -- n ) { 6 23 } sysctl-query-uint ; -M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ; +: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ; +: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ; : available-cpus ( -- n ) { 6 25 } sysctl-query-uint ; diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index f671ea9426..55c2ac6c0d 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -2,33 +2,30 @@ USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 hardware-info.backend ; IN: hardware-info.windows.ce -TUPLE: wince-os ; -T{ wince-os } os set-global - : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength [ GlobalMemoryStatus ] keep ; -M: wince-os cpus ( -- n ) 1 ; +M: wince cpus ( -- n ) 1 ; -M: wince-os memory-load ( -- n ) +M: wince memory-load ( -- n ) memory-status MEMORYSTATUS-dwMemoryLoad ; -M: wince-os physical-mem ( -- n ) +M: wince physical-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalPhys ; -M: wince-os available-mem ( -- n ) +M: wince available-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailPhys ; -M: wince-os total-page-file ( -- n ) +M: wince total-page-file ( -- n ) memory-status MEMORYSTATUS-dwTotalPageFile ; -M: wince-os available-page-file ( -- n ) +M: wince available-page-file ( -- n ) memory-status MEMORYSTATUS-dwAvailPageFile ; -M: wince-os total-virtual-mem ( -- n ) +M: wince total-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalVirtual ; -M: wince-os available-virtual-mem ( -- n ) +M: wince available-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailVirtual ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 8bdb75fe6a..ba9c1d74b5 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,15 +1,12 @@ USING: alien alien.c-types kernel libc math namespaces hardware-info.backend -windows windows.advapi32 windows.kernel32 ; +windows windows.advapi32 windows.kernel32 system ; IN: hardware-info.windows.nt -TUPLE: winnt-os ; -T{ winnt-os } os set-global - : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; -M: winnt-os cpus ( -- n ) +M: winnt cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) @@ -17,25 +14,25 @@ M: winnt-os cpus ( -- n ) "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; -M: winnt-os memory-load ( -- n ) +M: winnt memory-load ( -- n ) memory-status MEMORYSTATUSEX-dwMemoryLoad ; -M: winnt-os physical-mem ( -- n ) +M: winnt physical-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPhys ; -M: winnt-os available-mem ( -- n ) +M: winnt available-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPhys ; -M: winnt-os total-page-file ( -- n ) +M: winnt total-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPageFile ; -M: winnt-os available-page-file ( -- n ) +M: winnt available-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPageFile ; -M: winnt-os total-virtual-mem ( -- n ) +M: winnt total-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalVirtual ; -M: winnt-os available-virtual-mem ( -- n ) +M: winnt available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; : computer-name ( -- string ) diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index f3a1eb33f5..807fd158ba 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -65,6 +65,6 @@ IN: hardware-info.windows << { - { [ wince? ] [ "hardware-info.windows.ce" ] } - { [ winnt? ] [ "hardware-info.windows.nt" ] } + { [ os wince? ] [ "hardware-info.windows.ce" ] } + { [ os winnt? ] [ "hardware-info.windows.nt" ] } } cond [ require ] when* >> diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 319dd1586b..075ce2d0e8 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -267,16 +267,33 @@ $nl } ; ARTICLE: "cookbook-philosophy" "Factor philosophy" -"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write." +"Learning a stack language is like learning to ride a bicycle: it takes a bit of practice and you might graze your knees a couple of times, but once you get the hang of it, it becomes second nature." $nl -"If you try to write Factor word definitions which are longer than a couple of lines, you will find it hard to keep track of the stack contents. Well-written Factor code is " { $emphasis "factored" } " into short definitions, where each definition is easy to test interactively, and has a clear purpose. Well-chosen word names are critical, and having a thesaurus on hand really helps." -$nl -"If you run into problems with stack shuffling, take a deep breath and a step back, and reconsider the problem. A much simpler solution is waiting right around the corner, a natural solution which requires far less stack shuffling and far less code. As a last resort, if no simple solution exists, consider defining a domain-specific language." -$nl -"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition and save yourself some debugging time." -$nl -"In addition to writing short definitions and testing them interactively, a great habit to get into is writing unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } "." +"The most common difficulty encountered by beginners is trouble reading and writing code as a result of trying to place too many values on the stack at a time." $nl +"Keep the following guidelines in mind to avoid losing your sense of balance:" +{ $list + "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines." + "In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code." + "If your code looks repetitive, factor it some more." + "If after factoring, your code still looks repetitive, introduce combinators." + "If after introducing combinators, your code still looks repetitive, look into using meta-programming techniques." + "Try to place items on the stack in the order in which they are needed. If everything is in the correct order, no shuffling needs to be performed." + "If you find yourself writing a stack comment in the middle of a word, break the word up." + { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." } + { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." } + "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition." + { "Learn to use the " { $link "inference" } " tool." } + { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." } + "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution." + { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." } + { "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." } + { "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." } + { "If you find yourself wishing you could iterate over the datastack, or capture the contents of the datastack into a sequence, or push each element of a sequence onto the datastack, there is almost always a better way. Use " { $link "sequences" } " instead." } + "Don't use meta-programming if there's a simpler way." + "Don't worry about efficiency unless your program is too slow. Don't prefer complex code to simple code just because you feel it will be more efficient. The Factor compiler is designed to make idiomatic code run fast." + { "None of the above are hard-and-fast rules: there are exceptions to all of them. But one rule unconditionally holds: " { $emphasis "there is always a simpler way" } "." } +} "Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code." $nl "Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 912c3c35f3..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" } @@ -206,6 +207,7 @@ ARTICLE: "tools" "Developer tools" { $subsection "tools.vocabs" } "Exploratory tools:" { $subsection "editor" } +{ $subsection "listener" } { $subsection "tools.crossref" } { $subsection "inspector" } "Debugging tools:" @@ -260,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 5dc7255eed..b963a19f29 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -138,8 +138,7 @@ M: f print-element drop ; link-style get [ write-object ] with-style ; : ($link) ( article -- ) - dup article-name swap >link write-link - span last-element set ; + [ dup article-name swap >link write-link ] ($span) ; : $link ( element -- ) first ($link) ; @@ -235,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-tests.factor b/extra/io/sockets/sockets-tests.factor new file mode 100644 index 0000000000..1810b8587b --- /dev/null +++ b/extra/io/sockets/sockets-tests.factor @@ -0,0 +1,4 @@ +IN: io.sockets.tests +USING: io.sockets sequences math tools.test ; + +[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 1dc7f4883d..17799227b8 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -6,7 +6,8 @@ IN: io.sockets TUPLE: local path ; -C: local +: ( path -- addrspec ) + 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 b0b0ba456a..39c18b4601 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -3,15 +3,16 @@ USING: io.backend io.nonblocking io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitfields byte-arrays alien combinators calendar -io.encodings.binary ; +io.encodings.binary accessors sequences strings system +io.files.private ; IN: io.unix.files -M: unix-io cwd ( -- path ) +M: unix cwd ( -- path ) MAXPATHLEN [ ] [ ] bi getcwd [ (io-error) ] unless* ; -M: unix-io cd ( path -- ) +M: unix cd ( path -- ) chdir io-error ; : read-flags O_RDONLY ; inline @@ -19,7 +20,7 @@ M: unix-io cd ( path -- ) : open-read ( path -- fd ) O_RDONLY file-mode open dup io-error ; -M: unix-io (file-reader) ( path -- stream ) +M: unix (file-reader) ( path -- stream ) open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline @@ -27,7 +28,7 @@ M: unix-io (file-reader) ( path -- stream ) : open-write ( path -- fd ) write-flags file-mode open dup io-error ; -M: unix-io (file-writer) ( path -- stream ) +M: unix (file-writer) ( path -- stream ) open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline @@ -36,29 +37,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 +69,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 ; @@ -84,7 +85,7 @@ M: unix-io copy-file ( from to -- ) { [ dup S_ISLNK ] [ +symbolic-link+ ] } { [ dup S_ISSOCK ] [ +socket+ ] } { [ t ] [ +unknown+ ] } - } cond nip ; + } cond nip ; : stat>file-info ( stat -- info ) { @@ -95,8 +96,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 make-link ( path1 path2 -- ) + normalize-path symlink io-error ; + +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..5f0a9b96cb 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend io.unix.files io.nonblocking sequences kernel namespaces math system alien.c-types debugger continuations arrays assocs combinators unix.process strings threads unix -io.unix.launcher.parser accessors io.files ; +io.unix.launcher.parser accessors io.files io.files.private ; IN: io.unix.launcher ! Search unix first @@ -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 7580e7bf6b..78af0dd50d 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,14 +3,10 @@ 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 ; +namespaces threads continuations init math alien.c-types alien +vocabs.loader accessors system ; IN: io.unix.linux -TUPLE: linux-io ; - -INSTANCE: linux-io unix-io - TUPLE: linux-monitor ; : ( wd -- monitor ) @@ -18,7 +14,7 @@ TUPLE: linux-monitor ; TUPLE: inotify watches ; -: watches ( -- assoc ) inotify get-global inotify-watches ; +: watches ( -- assoc ) inotify get-global watches>> ; : wd>monitor ( wd -- monitor ) watches at ; @@ -29,7 +25,7 @@ TUPLE: inotify watches ; { set-inotify-watches set-delegate } inotify construct ] if ; -: inotify-fd inotify get-global port-handle ; +: inotify-fd inotify get-global handle>> ; : (add-watch) ( path mask -- wd ) inotify-fd -rot inotify_add_watch dup io-error ; @@ -52,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 ; @@ -80,10 +76,10 @@ M: linux-monitor dispose ( monitor -- ) parse-action swap alien>char-string ; : events-exhausted? ( i buffer -- ? ) - buffer-fill >= ; + fill>> >= ; : inotify-event@ ( i buffer -- alien ) - buffer-ptr ; + ptr>> ; : next-event ( i buffer -- i buffer ) 2dup inotify-event@ @@ -111,15 +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 ( -- ) - dup mx set-global init-inotify ; +M: linux init-io ( -- ) + + [ mx set-global ] + [ 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 bd7dfd9ce1..a54205a878 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces io.nonblocking parser threads unix sequences byte-arrays io.sockets io.binary io.unix.backend io.streams.duplex io.sockets.impl math.parser continuations libc -combinators ; +combinators io.backend io.files io.files.private system ; IN: io.unix.sockets : pending-init-error ( port -- ) @@ -23,7 +23,7 @@ IN: io.unix.sockets : sockopt ( fd level opt -- ) 1 "int" heap-size setsockopt io-error ; -M: unix-io addrinfo-error ( n -- ) +M: unix addrinfo-error ( n -- ) dup zero? [ drop ] [ gai_strerror throw ] if ; ! Client sockets - TCP and Unix domain @@ -42,7 +42,7 @@ M: connect-task do-io-task : wait-to-connect ( port -- ) [ add-io-task ] with-port-continuation drop ; -M: unix-io (client) ( addrspec -- client-in client-out ) +M: unix (client) ( addrspec -- client-in client-out ) dup make-sockaddr/size >r >r protocol-family SOCK_STREAM socket-fd dup r> r> connect @@ -91,11 +91,11 @@ USE: io.sockets dup rot make-sockaddr/size bind zero? [ dup close (io-error) ] unless ; -M: unix-io (server) ( addrspec -- handle ) +M: unix (server) ( addrspec -- handle ) SOCK_STREAM server-fd dup 10 listen zero? [ dup close (io-error) ] unless ; -M: unix-io (accept) ( server -- addrspec handle ) +M: unix (accept) ( server -- addrspec handle ) #! Wait for a client connection. dup check-server-port dup wait-to-accept @@ -104,7 +104,7 @@ M: unix-io (accept) ( server -- addrspec handle ) swap server-port-client ; ! Datagram sockets - UDP and Unix domain -M: unix-io +M: unix [ SOCK_DGRAM server-fd ] keep ; SYMBOL: receive-buffer @@ -147,7 +147,7 @@ M: receive-task do-io-task : wait-receive ( stream -- ) [ add-io-task ] with-port-continuation drop ; -M: unix-io receive ( datagram -- packet addrspec ) +M: unix receive ( datagram -- packet addrspec ) dup check-datagram-port dup wait-receive dup pending-error @@ -179,7 +179,7 @@ M: send-task do-io-task [ add-io-task ] with-port-continuation 2drop 2drop ; -M: unix-io send ( packet addrspec datagram -- ) +M: unix send ( packet addrspec datagram -- ) 3dup check-datagram-send [ >r make-sockaddr/size r> wait-send ] keep pending-error ; @@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ; M: local sockaddr-type drop "sockaddr-un" c-type ; M: local make-sockaddr - local-path + local-path cwd prepend-path dup length 1 + max-un-path > [ "Path too long" throw ] when "sockaddr-un" AF_UNIX over set-sockaddr-un-family 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..8bfbff2ba0 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types io.backend io.files io.windows kernel math windows windows.kernel32 windows.time calendar combinators -math.functions sequences namespaces words symbols -combinators.lib io.nonblocking destructors ; +math.functions sequences namespaces words symbols system +combinators.lib io.nonblocking destructors math.bitfields.lib ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ @@ -88,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..3232ab6ff3 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,22 +1,23 @@ USING: continuations destructors io.buffers io.files io.backend io.timeouts io.nonblocking io.windows io.windows.nt.backend -kernel libc math threads windows windows.kernel32 +kernel libc math threads windows windows.kernel32 system alien.c-types alien.arrays sequences combinators combinators.lib -sequences.lib ascii splitting alien strings assocs namespaces ; +sequences.lib ascii splitting alien strings assocs namespaces +io.files.private ; IN: io.windows.nt.files -M: windows-nt-io cwd +M: winnt cwd MAX_UNICODE_PATH dup "ushort" [ GetCurrentDirectory win32-error=0/f ] keep alien>u16-string ; -M: windows-nt-io cd +M: winnt cd SetCurrentDirectory win32-error=0/f ; : unicode-prefix ( -- seq ) "\\\\?\\" ; inline -M: windows-nt-io root-directory? ( path -- ? ) +M: winnt root-directory? ( path -- ? ) { { [ dup empty? ] [ f ] } { [ dup [ path-separator? ] all? ] [ t ] } @@ -36,33 +37,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/json/writer/writer.factor b/extra/json/writer/writer.factor index 1741b96e75..6ad0774e38 100644 --- a/extra/json/writer/writer.factor +++ b/extra/json/writer/writer.factor @@ -26,32 +26,27 @@ M: number json-print ( num -- ) M: integer json-print ( num -- ) number>string write ; -M: sequence json-print ( array -- string ) +M: sequence json-print ( array -- ) CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ; -: (jsvar-encode) ( char -- char ) - #! Convert the given character to a character usable in - #! javascript variable names. - dup H{ { CHAR: - CHAR: _ } } at dup [ nip ] [ drop ] if ; - : jsvar-encode ( string -- string ) #! Convert the string so that it contains characters usable within #! javascript variable names. - [ (jsvar-encode) ] map ; + { { CHAR: - CHAR: _ } } substitute ; -: tuple>fields ( object -- string ) +: tuple>fields ( object -- seq ) [ [ swap jsvar-encode >json % " : " % >json % ] "" make ] { } assoc>map ; -M: tuple json-print ( tuple -- string ) +M: tuple json-print ( tuple -- ) CHAR: { write1 tuple>fields "," join write CHAR: } write1 ; -M: hashtable json-print ( hashtable -- string ) +M: hashtable json-print ( hashtable -- ) CHAR: { write1 [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ] { } assoc>map "," join write CHAR: } write1 ; -M: object json-print ( object -- string ) +M: object json-print ( object -- ) unparse json-print ; 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/match/match.factor b/extra/match/match.factor index 2c6923a6ba..825d58c7c2 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -65,3 +65,26 @@ MACRO: match-cond ( assoc -- ) -rot match [ "Pattern does not match" throw ] unless* [ replace-patterns ] bind ; + +: ?1-tail ( seq -- tail/f ) + dup length zero? not [ 1 tail ] [ drop f ] if ; + +: (match-first) ( seq pattern-seq -- bindings leftover/f ) + 2dup [ length ] bi@ < [ 2drop f f ] + [ + 2dup length head over match + [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if* + ] if ; + +: match-first ( seq pattern-seq -- bindings ) + (match-first) drop ; + +: (match-all) ( seq pattern-seq -- ) + tuck (match-first) swap + [ + , [ swap (match-all) ] [ drop ] if* + ] [ 2drop ] if* ; + +: match-all ( seq pattern-seq -- bindings-seq ) + [ (match-all) ] { } make ; + diff --git a/extra/math/bitfields/lib/lib-docs.factor b/extra/math/bitfields/lib/lib-docs.factor new file mode 100644 index 0000000000..bfbe9eaded --- /dev/null +++ b/extra/math/bitfields/lib/lib-docs.factor @@ -0,0 +1,16 @@ +USING: help.markup help.syntax kernel math sequences ; +IN: math.bitfields.lib + +HELP: bits +{ $values { "m" integer } { "n" integer } { "m'" integer } } +{ $description "Keep only n bits from the integer m." } +{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ; + +HELP: bitroll +{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } +{ $description "Roll n by s bits to the left, wrapping around after w bits." } +{ $examples + { $example "USING: math.bitfields.lib prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } + { $example "USING: math.bitfields.lib prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } +} ; + diff --git a/extra/crypto/test/common.factor b/extra/math/bitfields/lib/lib-tests.factor similarity index 85% rename from extra/crypto/test/common.factor rename to extra/math/bitfields/lib/lib-tests.factor index 6050454402..c002240e69 100644 --- a/extra/crypto/test/common.factor +++ b/extra/math/bitfields/lib/lib-tests.factor @@ -1,4 +1,5 @@ -USING: kernel math test namespaces crypto ; +USING: math.bitfields.lib tools.test ; +IN: math.bitfields.lib.test [ 0 ] [ 1 0 0 bitroll ] unit-test [ 1 ] [ 1 0 1 bitroll ] unit-test @@ -11,5 +12,3 @@ USING: kernel math test namespaces crypto ; [ 1 ] [ 1 -32 8 bitroll ] unit-test [ 128 ] [ 1 -1 8 bitroll ] unit-test [ 8 ] [ 1 3 32 bitroll ] unit-test - - diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor new file mode 100644 index 0000000000..72b33b9ae7 --- /dev/null +++ b/extra/math/bitfields/lib/lib.factor @@ -0,0 +1,30 @@ +USING: hints kernel math ; +IN: math.bitfields.lib + +: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable +: set-bit ( x n -- y ) 2^ bitor ; foldable +: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable +: unmask ( x n -- ? ) bitnot bitand ; foldable +: unmask? ( x n -- ? ) unmask 0 > ; foldable +: mask ( x n -- ? ) bitand ; foldable +: mask? ( x n -- ? ) mask 0 > ; foldable +: wrap ( m n -- m' ) 1- bitand ; foldable +: bits ( m n -- m' ) 2^ wrap ; inline +: mask-bit ( m n -- m' ) 1- 2^ mask ; inline + +: shift-mod ( n s w -- n ) + >r shift r> 2^ wrap ; inline + +: bitroll ( x s w -- y ) + [ wrap ] keep + [ shift-mod ] + [ [ - ] keep shift-mod ] 3bi bitor ; inline + +: bitroll-32 ( n s -- n' ) 32 bitroll ; + +HINTS: bitroll-32 bignum fixnum ; + +: bitroll-64 ( n s -- n' ) 64 bitroll ; + +HINTS: bitroll-64 bignum fixnum ; + diff --git a/extra/math/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/functions/functions.factor b/extra/math/functions/functions.factor index dcbccb4316..77c7d9247d 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -30,15 +30,6 @@ M: real sqrt 2dup >r >r >r odd? r> call r> 2/ r> each-bit ] if ; inline -: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable -: set-bit ( x n -- y ) 2^ bitor ; foldable -: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable -: bit-set? ( x n -- ? ) bit-clear? not ; foldable -: unmask ( x n -- ? ) bitnot bitand ; foldable -: unmask? ( x n -- ? ) unmask 0 > ; foldable -: mask ( x n -- ? ) bitand ; foldable -: mask? ( x n -- ? ) mask 0 > ; foldable - GENERIC: (^) ( x y -- z ) foldable : ^n ( z w -- z^w ) diff --git a/extra/math/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/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index c689f729d1..c85c0ee218 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -11,11 +11,12 @@ namespaces math math.parser openssl prettyprint sequences tools.test ; ] [ "Hello world from the openssl binding" >md5 ] unit-test -[ - B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 - 82 115 0 } -] -[ "Hello world from the openssl binding" >sha1 ] unit-test +! Not found on netbsd, windows -- why? +! [ + ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 + ! 82 115 0 } +! ] +! [ "Hello world from the openssl binding" >sha1 ] unit-test ! ========================================================= ! Initialize context 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/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 7aa61e84da..0879ecda49 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.ebnf words ; +USING: kernel tools.test peg peg.ebnf words math math.parser sequences ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ @@ -160,6 +160,74 @@ IN: peg.ebnf.tests "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast ] unit-test +{ 6 } [ + "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call parse-result-ast +] unit-test + +{ 6 } [ + "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast +] unit-test + +{ 10 } [ + { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast +] unit-test + +{ f } [ + { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call +] unit-test + +{ 3 } [ + { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast +] unit-test + +{ f } [ + "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call +] unit-test + +{ V{ "a" " " "b" } } [ + "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "\t" "b" } } [ + "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "\n" "b" } } [ + "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" f "b" } } [ + "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" " " "b" } } [ + "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast +] unit-test + + +{ V{ "a" "\t" "b" } } [ + "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "\n" "b" } } [ + "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "b" } } [ + "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "b" } } [ + "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ V{ "a" "b" } } [ + "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast +] unit-test + +{ f } [ + "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call +] unit-test { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. @@ -179,9 +247,13 @@ IN: peg.ebnf.tests "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast ] unit-test +{ t } [ + "abcd='9' | ('8'):x => [[ drop x ]]" 'ebnf' parse parse-result-remaining empty? +] unit-test + EBNF: primary Primary = PrimaryNoNewArray -PrimaryNoNewArray = ClassInstanceCreationExpression +PrimaryNoNewArray = ClassInstanceCreationExpression | MethodInvocation | FieldAccess | ArrayAccess @@ -192,7 +264,7 @@ MethodInvocation = Primary "." MethodName "(" ")" | MethodName "(" ")" FieldAccess = Primary "." Identifier | "super" "." Identifier -ArrayAccess = Primary "[" Expression "]" +ArrayAccess = Primary "[" Expression "]" | ExpressionName "[" Expression "]" ClassOrInterfaceType = ClassName | InterfaceTypeName ClassName = "C" | "D" diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index af61c3aae0..e5787e6cf8 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -3,7 +3,7 @@ USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg peg.parsers unicode.categories multiline combinators.lib - splitting accessors ; + splitting accessors effects sequences.deep peg.search ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -19,6 +19,8 @@ TUPLE: ebnf-repeat1 group ; TUPLE: ebnf-optional group ; TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-action parser code ; +TUPLE: ebnf-var parser name ; +TUPLE: ebnf-semantic parser code ; TUPLE: ebnf rules ; C: ebnf-non-terminal @@ -34,6 +36,8 @@ C: ebnf-repeat1 C: ebnf-optional C: ebnf-rule C: ebnf-action +C: ebnf-var +C: ebnf-semantic C: ebnf : syntax ( string -- parser ) @@ -79,6 +83,7 @@ C: ebnf [ dup CHAR: * = ] [ dup CHAR: + = ] [ dup CHAR: ? = ] + [ dup CHAR: : = ] } || not nip ] satisfy repeat1 [ >string ] action ; @@ -99,7 +104,7 @@ C: ebnf "]" syntax , ] seq* [ first >string ] action ; -: 'element' ( -- parser ) +: ('element') ( -- parser ) #! An element of a rule. It can be a terminal or a #! non-terminal but must not be followed by a "=". #! The latter indicates that it is the beginning of a @@ -117,6 +122,12 @@ C: ebnf ] choice* , ] seq* [ first ] action ; +: 'element' ( -- parser ) + [ + [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , + ('element') , + ] choice* ; + DEFER: 'choice' : grouped ( quot suffix -- parser ) @@ -147,6 +158,7 @@ DEFER: 'choice' : 'factor-code' ( -- parser ) [ "]]" token ensure-not , + "]?" token ensure-not , [ drop t ] satisfy , ] seq* [ first ] action repeat0 [ >string ] action ; @@ -184,14 +196,15 @@ DEFER: 'choice' : 'action' ( -- parser ) "[[" 'factor-code' "]]" syntax-pack ; +: 'semantic' ( -- parser ) + "?[" 'factor-code' "]?" syntax-pack ; + : 'sequence' ( -- parser ) #! A sequence of terminals and non-terminals, including #! groupings of those. [ - [ - ('sequence') , - 'action' , - ] seq* [ first2 ] action , + [ ('sequence') , 'action' , ] seq* [ first2 ] action , + [ ('sequence') , 'semantic' , ] seq* [ first2 ] action , ('sequence') , ] choice* repeat1 [ dup length 1 = [ first ] [ ] if @@ -200,6 +213,8 @@ DEFER: 'choice' : 'actioned-sequence' ( -- parser ) [ [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 ] action , + [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , "=>" syntax , 'action' , ] seq* [ first3 >r r> ] action , + [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , 'sequence' , ] choice* ; @@ -231,12 +246,13 @@ M: ebnf (transform) ( ast -- parser ) rules>> [ (transform) ] map peek ; M: ebnf-rule (transform) ( ast -- parser ) - dup elements>> (transform) [ + dup elements>> + (transform) [ swap symbol>> set ] keep ; M: ebnf-sequence (transform) ( ast -- parser ) - elements>> [ (transform) ] map seq ; + elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ; M: ebnf-choice (transform) ( ast -- parser ) options>> [ (transform) ] map choice ; @@ -266,16 +282,62 @@ M: ebnf-repeat1 (transform) ( ast -- parser ) M: ebnf-optional (transform) ( ast -- parser ) transform-group optional ; +GENERIC: build-locals ( code ast -- code ) + +M: ebnf-sequence build-locals ( code ast -- code ) + elements>> dup [ ebnf-var? ] subset empty? [ + drop + ] [ + [ + "USING: locals sequences ; [let* | " % + dup length swap [ + dup ebnf-var? [ + name>> % + " [ " % # " over nth ] " % + ] [ + 2drop + ] if + ] 2each + " | " % + % + " ] with-locals" % + ] "" make + ] if ; + +M: ebnf-var build-locals ( code ast -- ) + [ + "USING: locals kernel ; [let* | " % + name>> % " [ dup ] " % + " | " % + % + " ] with-locals" % + ] "" make ; + +M: object build-locals ( code ast -- ) + drop ; + M: ebnf-action (transform) ( ast -- parser ) - [ parser>> (transform) ] keep - code>> string-lines [ parse-lines ] with-compilation-unit action ; + [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals + string-lines [ parse-lines ] with-compilation-unit action ; + +M: ebnf-semantic (transform) ( ast -- parser ) + [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals + string-lines [ parse-lines ] with-compilation-unit semantic ; + +M: ebnf-var (transform) ( ast -- parser ) + parser>> (transform) ; M: ebnf-terminal (transform) ( ast -- parser ) - symbol>> token sp ; + symbol>> token ; + +: parser-not-found ( name -- * ) + [ + "Parser " % % " not found." % + ] "" make throw ; M: ebnf-non-terminal (transform) ( ast -- parser ) symbol>> [ - , parser get , \ at , \ sp , + , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip , ] [ ] make box ; : transform-ebnf ( string -- object ) @@ -283,7 +345,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : check-parse-result ( result -- result ) dup [ - dup parse-result-remaining empty? [ + dup parse-result-remaining [ blank? ] trim empty? [ [ "Unable to fully parse EBNF. Left to parse was: " % parse-result-remaining % @@ -296,12 +358,18 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : ebnf>quot ( string -- hashtable quot ) 'ebnf' parse check-parse-result parse-result-ast transform dup dup parser [ main swap at compile ] with-variable - [ compiled-parse ] curry ; + [ compiled-parse ] curry [ with-scope ] curry ; -: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing +: replace-escapes ( string -- string ) + "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ; + +: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing : EBNF: CREATE-WORD dup - ";EBNF" parse-multiline-string - ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing + ";EBNF" parse-multiline-string replace-escapes + ebnf>quot swapd 1 1 define-declared "ebnf-parser" set-word-prop ; parsing +: rule ( name word -- parser ) + #! Given an EBNF word produced from EBNF: return the EBNF rule + "ebnf-parser" word-prop at ; \ No newline at end of file diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index e7bd255569..5f200be78e 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -95,6 +95,19 @@ HELP: optional "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is " "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ; +HELP: semantic +{ $values + { "parser" "a parser" } + { "quot" "a quotation with stack effect ( object -- bool )" } +} +{ $description + "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with " + "the AST produced by 'p1' on the stack returns true." } +{ $examples + { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" } + { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" } +} ; + HELP: ensure { $values { "parser" "a parser" } @@ -124,7 +137,7 @@ HELP: action "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting " "from that parse. The result of the quotation is then used as the final AST. This can be used " "for manipulating the parse tree to produce a AST better suited for the task at hand rather than " - "the default AST." } + "the default AST. If the quotation returns " { $link fail } " then the parser fails." } { $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ; HELP: sp diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index f57fe83220..fcec33f7c2 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words ; +USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ; IN: peg.tests { f } [ @@ -182,4 +182,13 @@ IN: peg.tests [ f , "a" token , ] seq* dup parsers>> dupd 0 swap set-nth compile word? -] unit-test \ No newline at end of file +] unit-test + +{ f } [ + "A" [ drop t ] satisfy [ 66 >= ] semantic parse +] unit-test + +{ CHAR: B } [ + "B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast +] unit-test + diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 68aab7d820..217805ce47 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words quotations effects memoize accessors locals ; + words quotations effects memoize accessors locals effects ; IN: peg USE: prettyprint @@ -30,6 +30,14 @@ SYMBOL: fail SYMBOL: lrstack SYMBOL: heads +: delegates ( -- cache ) + \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; + +: reset-pegs ( -- ) + H{ } clone \ delegates set-global ; + +reset-pegs + TUPLE: memo-entry ans pos ; C: memo-entry @@ -104,7 +112,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 +144,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? [ @@ -208,7 +216,7 @@ GENERIC: (compile) ( parser -- quot ) :: parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - [let* | rule [ parser (compile) define-temp dup parser "peg" set-word-prop ] + [let* | rule [ gensym dup parser (compile) 0 1 define-declared dup parser "peg" set-word-prop ] | [ rule pos get apply-rule dup fail = [ @@ -218,7 +226,7 @@ GENERIC: (compile) ( parser -- quot ) ] if ] ] ; - + : compiled-parser ( parser -- word ) #! Look to see if the given parser has been compiled. #! If not, compile it to a temporary word, cache it, @@ -229,7 +237,7 @@ GENERIC: (compile) ( parser -- quot ) dup compiled>> [ nip ] [ - gensym tuck >>compiled 2dup parser-body define dupd "peg" set-word-prop + gensym tuck >>compiled 2dup parser-body 0 1 define-declared dupd "peg" set-word-prop ] if* ; : compile ( parser -- word ) @@ -253,14 +261,6 @@ SYMBOL: id 1 id set-global 0 ] if* ; -: delegates ( -- cache ) - \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; - -: reset-delegates ( -- ) - H{ } clone \ delegates set-global ; - -reset-delegates - : init-parser ( parser -- parser ) #! Set the delegate for the parser. Equivalent parsers #! get a delegate with the same id. @@ -414,6 +414,23 @@ TUPLE: optional-parser p1 ; M: optional-parser (compile) ( parser -- quot ) p1>> compiled-parser \ ?quot optional-pattern match-replace ; +TUPLE: semantic-parser p1 quot ; + +MATCH-VARS: ?parser ; + +: semantic-pattern ( -- quot ) + [ + ?parser [ + dup parse-result-ast ?quot call [ drop f ] unless + ] [ + f + ] if* + ] ; + +M: semantic-parser (compile) ( parser -- quot ) + [ p1>> compiled-parser ] [ quot>> ] bi + 2array { ?parser ?quot } semantic-pattern match-replace ; + TUPLE: ensure-parser p1 ; : ensure-pattern ( -- quot ) @@ -490,8 +507,11 @@ M: box-parser (compile) ( parser -- quot ) #! Calls the quotation at compile time #! to produce the parser to be compiled. #! This differs from 'delay' which calls - #! it at run time. - quot>> call compiled-parser 1quotation ; + #! it at run time. Due to using the runtime + #! environment at compile time, this parser + #! must not be cached, so we clear out the + #! delgates cache. + f >>compiled quot>> call compiled-parser 1quotation ; PRIVATE> @@ -543,6 +563,9 @@ PRIVATE> : optional ( parser -- parser ) optional-parser construct-boa init-parser ; +: semantic ( parser quot -- parser ) + semantic-parser construct-boa init-parser ; + : ensure ( parser -- parser ) ensure-parser construct-boa init-parser ; @@ -562,7 +585,18 @@ PRIVATE> delay-parser construct-boa init-parser ; : box ( quot -- parser ) - box-parser construct-boa init-parser ; + #! because a box has its quotation run at compile time + #! it must always have a new parser delgate created, + #! not a cached one. This is because the same box, + #! compiled twice can have a different compiled word + #! due to running at compile time. + #! Why the [ ] action at the end? Box parsers don't get + #! memoized during parsing due to all box parsers being + #! unique. This breaks left recursion detection during the + #! parse. The action adds an indirection with a parser type + #! that gets memoized and fixes this. Need to rethink how + #! to fix boxes so this isn't needed... + box-parser construct-boa next-id f over set-delegate [ ] action ; : PEG: (:) [ diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index b3d2135da7..88993c354b 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -1,9 +1,45 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.pl0 multiline sequences ; +USING: kernel tools.test peg peg.ebnf peg.pl0 multiline sequences ; IN: peg.pl0.tests +{ t } [ + "CONST foo = 1;" "block" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "VAR foo;" "block" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "VAR foo,bar , baz;" "block" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "BEGIN foo := 5 END" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty? +] unit-test + +{ t } [ + "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse parse-result-remaining empty? +] unit-test + { t } [ <" VAR x, squ; diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index f7eb3cad23..1b97814ca7 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -7,20 +7,52 @@ IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 EBNF: pl0 -block = ( "CONST" ident "=" number ( "," ident "=" number )* ";" )? - ( "VAR" ident ( "," ident )* ";" )? - ( "PROCEDURE" ident ";" ( block ";" )? )* statement -statement = ( ident ":=" expression | "CALL" ident | - "BEGIN" statement (";" statement )* "END" | - "IF" condition "THEN" statement | - "WHILE" condition "DO" statement )? -condition = "ODD" expression | - expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression -expression = ("+" | "-")? term (("+" | "-") term )* -term = factor (("*" | "/") factor )* -factor = ident | number | "(" expression ")" -ident = (([a-zA-Z])+) [[ >string ]] -digit = ([0-9]) [[ digit> ]] -number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]] -program = block "." +_ = (" " | "\t" | "\n")* => [[ drop ignore ]] + +BEGIN = "BEGIN" _ +CALL = "CALL" _ +CONST = "CONST" _ +DO = "DO" _ +END = "END" _ +IF = "IF" _ +THEN = "THEN" _ +ODD = "ODD" _ +PROCEDURE = "PROCEDURE" _ +VAR = "VAR" _ +WHILE = "WHILE" _ +EQ = "=" _ +LTEQ = "<=" _ +LT = "<" _ +GT = ">" _ +GTEQ = ">=" _ +NEQ = "#" _ +COMMA = "," _ +SEMICOLON = ";" _ +ASSIGN = ":=" _ + +ADD = "+" _ +SUBTRACT = "-" _ +MULTIPLY = "*" _ +DIVIDE = "/" _ + +LPAREN = "(" _ +RPAREN = ")" _ + +block = ( CONST ident EQ number ( COMMA ident EQ number )* SEMICOLON )? + ( VAR ident ( COMMA ident )* SEMICOLON )? + ( PROCEDURE ident SEMICOLON ( block SEMICOLON )? )* statement +statement = ( ident ASSIGN expression + | CALL ident + | BEGIN statement ( SEMICOLON statement )* END + | IF condition THEN statement + | WHILE condition DO statement )? +condition = ODD expression + | expression (EQ | NEQ | LTEQ | LT | GTEQ | GT) expression +expression = (ADD | SUBTRACT)? term ( (ADD | SUBTRACT) term )* _ +term = factor ( (MULTIPLY | DIVIDE) factor )* +factor = ident | number | LPAREN expression RPAREN +ident = (([a-zA-Z])+) _ => [[ >string ]] +digit = ([0-9]) => [[ digit> ]] +number = ((digit)+) _ => [[ 10 digits>integer ]] +program = _ block "." ;EBNF diff --git a/extra/project-euler/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 ad9dae51ae..46f2088440 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c - USING: arrays kernel math namespaces sequences system init -accessors math.ranges new-effects random ; +accessors math.ranges random circular math.bitfields.lib +combinators ; IN: random.mersenne-twister = [ - ] [ drop ] if ; inline -: mt-wrap ( x -- y ) mt-n wrap ; inline -: set-generated ( mt y from-elt to -- ) - >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi - r> bitxor bitxor r> new-set-nth drop ; inline +: calculate-y ( n seq -- y ) + [ nth 32 mask-bit ] + [ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline -: calculate-y ( mt y1 y2 -- y ) - >r over r> - [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline - -: (mt-generate) ( mt-seq n -- y to from-elt ) - [ dup 1+ mt-wrap calculate-y ] - [ mt-m + mt-wrap new-nth ] - [ nip ] 2tri ; +: (mt-generate) ( n seq -- next-mt ) + [ + calculate-y + [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor + ] [ + [ mt-m + ] [ nth ] bi* + ] 2bi bitxor ; : mt-generate ( mt -- ) - [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ] - [ 0 >>i drop ] bi ; + [ + mt-n swap seq>> [ + [ (mt-generate) ] [ set-nth ] 2bi + ] curry each + ] [ 0 >>i drop ] bi ; -: init-mt-first ( seed -- seq ) - >r mt-n 0 r> - HEX: ffffffff bitand 0 new-set-nth ; - -: init-mt-formula ( seq i -- f(seq[i]) ) - tuck new-nth dup -30 shift bitxor 1812433253 * + - 1+ HEX: ffffffff bitand ; +: init-mt-formula ( i seq -- f(seq[i]) ) + dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; : init-mt-rest ( seq -- ) - mt-n 1- [0,b) [ - dupd [ init-mt-formula ] keep 1+ new-set-nth drop - ] with each ; + mt-n 1- swap [ + [ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi + ] curry each ; : init-mt-seq ( seed -- seq ) - init-mt-first dup init-mt-rest ; + 32 bits mt-n 0 + [ set-first ] [ init-mt-rest ] [ ] tri ; : mt-temper ( y -- yt ) dup -11 shift bitxor @@ -58,6 +52,9 @@ TUPLE: mersenne-twister seq i ; dup 15 shift HEX: efc60000 bitand bitxor dup -18 shift bitxor ; inline +: next-index ( mt -- i ) + dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; + PRIVATE> : ( seed -- obj ) @@ -68,7 +65,6 @@ M: mersenne-twister seed-random ( mt seed -- ) init-mt-seq >>seq drop ; M: mersenne-twister random-32* ( mt -- r ) - dup [ seq>> ] [ i>> ] bi - dup mt-n < [ drop 0 pick mt-generate ] unless - new-nth mt-temper - swap [ 1+ ] change-i drop ; + [ next-index ] + [ seq>> nth mt-temper ] + [ [ 1+ ] change-i drop ] tri ; diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 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/serialize/serialize.factor b/extra/serialize/serialize.factor index ac247057f4..7a2fbfae9e 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -90,13 +90,13 @@ M: float (serialize) ( obj -- ) M: complex (serialize) ( obj -- ) CHAR: c write1 - dup real-part (serialize) - imaginary-part (serialize) ; + [ real-part (serialize) ] + [ imaginary-part (serialize) ] bi ; M: ratio (serialize) ( obj -- ) CHAR: r write1 - dup numerator (serialize) - denominator (serialize) ; + [ numerator (serialize) ] + [ denominator (serialize) ] bi ; : serialize-seq ( obj code -- ) [ @@ -120,7 +120,8 @@ M: array (serialize) ( obj -- ) M: quotation (serialize) ( obj -- ) [ - CHAR: q write1 [ >array (serialize) ] [ add-object ] bi + CHAR: q write1 + [ >array (serialize) ] [ add-object ] bi ] serialize-shared ; M: hashtable (serialize) ( obj -- ) @@ -234,10 +235,12 @@ SYMBOL: deserialized ] if ; : deserialize-gensym ( -- word ) - gensym - dup intern-object - dup (deserialize) define - dup (deserialize) swap set-word-props ; + gensym { + [ intern-object ] + [ (deserialize) define ] + [ (deserialize) swap set-word-props ] + [ ] + } cleave ; : deserialize-wrapper ( -- wrapper ) (deserialize) ; 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 479ae9c42c..5b835cd52f 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -26,11 +26,14 @@ M: pair make-disassemble-cmd M: method-spec make-disassemble-cmd first2 method make-disassemble-cmd ; +: gdb-binary ( -- string ) + os freebsd? "gdb66" "gdb" ? ; + : run-gdb ( -- lines ) +closed+ >>stdin out-file >>stdout - [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command + [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command try-process out-file ascii file-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 cb7b347c20..d80db44348 100755 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -24,16 +24,6 @@ IN: unix : F_SETFL 4 ; inline : O_NONBLOCK 4 ; inline -C-STRUCT: addrinfo - { "int" "flags" } - { "int" "family" } - { "int" "socktype" } - { "int" "protocol" } - { "socklen_t" "addrlen" } - { "char*" "canonname" } - { "void*" "addr" } - { "addrinfo*" "next" } ; - C-STRUCT: sockaddr-in { "uchar" "len" } { "uchar" "family" } @@ -83,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/bsd/freebsd/freebsd.factor b/extra/unix/bsd/freebsd/freebsd.factor index 94bb708527..f25cbd1537 100644 --- a/extra/unix/bsd/freebsd/freebsd.factor +++ b/extra/unix/bsd/freebsd/freebsd.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 1024 ; + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "char*" "canonname" } + { "void*" "addr" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/bsd/macosx/macosx.factor b/extra/unix/bsd/macosx/macosx.factor index 3c0617ad17..edef2aaa0c 100644 --- a/extra/unix/bsd/macosx/macosx.factor +++ b/extra/unix/bsd/macosx/macosx.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 1024 ; inline + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "char*" "canonname" } + { "void*" "addr" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/bsd/netbsd/netbsd.factor b/extra/unix/bsd/netbsd/netbsd.factor index ac18749830..071daa682d 100644 --- a/extra/unix/bsd/netbsd/netbsd.factor +++ b/extra/unix/bsd/netbsd/netbsd.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 256 ; inline + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "char*" "canonname" } + { "void*" "addr" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/bsd/openbsd/openbsd.factor b/extra/unix/bsd/openbsd/openbsd.factor index 3c0617ad17..29b44f7da6 100644 --- a/extra/unix/bsd/openbsd/openbsd.factor +++ b/extra/unix/bsd/openbsd/openbsd.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 1024 ; inline + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "void*" "addr" } + { "char*" "canonname" } + { "addrinfo*" "next" } ; 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 bed87ebd0f..e911a5c039 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -77,6 +77,7 @@ FUNCTION: int pclose ( void* file ) ; FUNCTION: int pipe ( int* filedes ) ; FUNCTION: void* popen ( char* command, char* type ) ; FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; +FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ; FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ; FUNCTION: int rename ( char* from, char* to ) ; @@ -93,6 +94,7 @@ FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_ FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; FUNCTION: char* strerror ( int errno ) ; +FUNCTION: int symlink ( char* path1, char* path2 ) ; FUNCTION: int system ( char* command ) ; FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; @@ -102,6 +104,8 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ; FUNCTION: int kill ( pid_t pid, int sig ) ; +: PATH_MAX 1024 ; inline + : PRIO_PROCESS 0 ; inline : PRIO_PGRP 1 ; inline : PRIO_USER 2 ; inline @@ -157,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/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);