diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 436d73e874..777bf523a5 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -7,7 +7,7 @@ IN: alien ! Some predicate classes used by the compiler for optimization ! purposes -PREDICATE: alien simple-alien +PREDICATE: simple-alien < alien underlying-alien not ; UNION: simple-c-ptr @@ -18,7 +18,7 @@ alien POSTPONE: f byte-array bit-array float-array ; DEFER: pinned-c-ptr? -PREDICATE: alien pinned-alien +PREDICATE: pinned-alien < alien underlying-alien pinned-c-ptr? ; UNION: pinned-c-ptr diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor old mode 100644 new mode 100755 index 714973e7ca..414c64581e --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -31,4 +31,4 @@ INSTANCE: array sequence : 4array ( w x y z -- array ) { } 4sequence ; flushable -PREDICATE: array pair length 2 number= ; +PREDICATE: pair < array length 2 number= ; diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor old mode 100644 new mode 100755 index a0a60e875a..574002921a --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -93,3 +93,14 @@ unit-test ] [ F{ 1.0 2.0 } [ dup ] H{ } map>assoc ] unit-test + +[ { 3 } ] [ + [ + 3 + H{ } clone + 2 [ + 2dup [ , f ] cache + ] times + 2drop + ] make +] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ff0938e001..196ec614b7 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -134,11 +134,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) (substitute) map ; : cache ( key assoc quot -- value ) - 2over at [ + 2over at* [ >r 3drop r> ] [ - pick rot >r >r call dup r> r> set-at - ] if* ; inline + drop pick rot >r >r call dup r> r> set-at + ] if ; inline : change-at ( key assoc quot -- ) [ >r at r> call ] 3keep drop set-at ; inline diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 04d57dff16..af2cc79579 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -36,7 +36,7 @@ nl { roll -roll declare not - tuple-class-eq? array? hashtable? vector? + array? hashtable? vector? tuple? sbuf? node? tombstone? array-capacity array-nth set-array-nth diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 6aa4b9212d..7fd4361246 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -4,7 +4,7 @@ USING: alien arrays bit-arrays byte-arrays generic assocs hashtables assocs hashtables.private io kernel kernel.private math namespaces parser prettyprint sequences sequences.private strings sbufs vectors words quotations assocs system layouts -splitting growable classes tuples words.private +splitting growable classes tuples tuples.private words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger float-arrays quotations.private sequences.private combinators io.encodings.binary ; @@ -294,17 +294,14 @@ M: bit-array ' bit-array emit-dummy-array ; M: float-array ' float-array emit-dummy-array ; -! Arrays -: emit-array ( list type tag -- pointer ) - >r >r [ ' ] map r> r> [ - dup length emit-fixnum - emit-seq - ] emit-object ; - -: emit-tuple ( obj -- pointer ) +! Tuples +: emit-tuple ( tuple -- pointer ) [ - [ tuple>array unclip transfer-word , % ] { } make - tuple type-number dup emit-array + [ + 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" = @@ -312,11 +309,31 @@ M: float-array ' float-array emit-dummy-array ; M: tuple ' emit-tuple ; +M: tuple-layout ' + objects get [ + [ + dup layout-hashcode ' , + dup layout-class ' , + dup layout-size ' , + dup layout-superclasses ' , + layout-echelon ' , + ] { } make + \ tuple-layout type-number + object tag-number [ emit-seq ] emit-object + ] cache ; + M: tombstone ' delegate "((tombstone))" "((empty))" ? "hashtables.private" lookup 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 ; diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index e15a7b4d7c..316fa3cd72 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -2,13 +2,13 @@ ! 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 tuples ; +float-arrays quotations assocs layouts tuples tuples.private ; BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -19 num-types set +20 num-types set H{ { fixnum BIN: 000 } @@ -33,4 +33,5 @@ tag-numbers get H{ { alien 16 } { word 17 } { byte-array 18 } + { tuple-layout 19 } } union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 0f38839c87..3f6fedb40c 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -3,8 +3,8 @@ USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes tuples -kernel.private vocabs vocabs.loader source-files definitions -slots.deprecated classes.union compiler.units +tuples.private kernel.private vocabs vocabs.loader source-files +definitions slots.deprecated classes.union compiler.units bootstrap.image.private io.files ; IN: bootstrap.primitives @@ -33,7 +33,6 @@ H{ } clone changed-words set H{ } clone root-cache set H{ } clone source-files set H{ } clone update-map set -num-types get f builtins set init-caches ! Vocabulary for slot accessors @@ -47,6 +46,9 @@ call call call +! After we execute bootstrap/layouts +num-types get f builtins set + ! Create some empty vocabs where the below primitives and ! classes will go { @@ -141,8 +143,6 @@ call "bignum" "math" create { } define-builtin "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop -"tuple" "kernel" create { } define-builtin - "ratio" "math" create { { { "integer" "math" } @@ -178,8 +178,6 @@ call "f" "syntax" lookup { } define-builtin -! do not word... - "array" "arrays" create { } define-builtin "wrapper" "kernel" create { @@ -293,6 +291,48 @@ define-builtin "callstack" "kernel" create { } define-builtin +"tuple-layout" "tuples.private" create { + { + { "fixnum" "math" } + "hashcode" + { "layout-hashcode" "tuples.private" } + f + } + { + { "word" "words" } + "class" + { "layout-class" "tuples.private" } + f + } + { + { "fixnum" "math" } + "size" + { "layout-size" "tuples.private" } + f + } + { + { "array" "arrays" } + "superclasses" + { "layout-superclasses" "tuples.private" } + f + } + { + { "fixnum" "math" } + "echelon" + { "layout-echelon" "tuples.private" } + f + } +} define-builtin + +"tuple" "kernel" create { + { + { "tuple-layout" "tuples.private" } + "layout" + { "tuple-layout" "tuples.private" } + f + } +} define-builtin + ! Define general-t type, which is any object that is not f. "general-t" "kernel" create "f" "syntax" lookup builtins get remove [ ] subset f union-class @@ -318,7 +358,9 @@ builtins get num-tags get tail f union-class define-class "null" "kernel" create { } f union-class define-class ! Create special tombstone values -"tombstone" "hashtables.private" create { } define-tuple-class +"tombstone" "hashtables.private" create +"tuple" "kernel" lookup +{ } define-tuple-class "((empty))" "hashtables.private" create "tombstone" "hashtables.private" lookup f @@ -330,6 +372,7 @@ builtins get num-tags get tail f union-class define-class ! Some tuple classes "hashtable" "hashtables" create +"tuple" "kernel" lookup { { { "array-capacity" "sequences.private" } @@ -350,6 +393,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "sbuf" "sbufs" create +"tuple" "kernel" lookup { { { "string" "strings" } @@ -365,6 +409,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "vector" "vectors" create +"tuple" "kernel" lookup { { { "array" "arrays" } @@ -380,6 +425,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "byte-vector" "byte-vectors" create +"tuple" "kernel" lookup { { { "byte-array" "byte-arrays" } @@ -395,6 +441,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "bit-vector" "bit-vectors" create +"tuple" "kernel" lookup { { { "bit-array" "bit-arrays" } @@ -410,6 +457,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "float-vector" "float-vectors" create +"tuple" "kernel" lookup { { { "float-array" "float-arrays" } @@ -425,6 +473,7 @@ builtins get num-tags get tail f union-class define-class } define-tuple-class "curry" "kernel" create +"tuple" "kernel" lookup { { { "object" "kernel" } @@ -439,7 +488,12 @@ builtins get num-tags get tail f union-class define-class } } define-tuple-class +"curry" "kernel" lookup +dup f "inline" set-word-prop +dup tuple-layout [ ] curry define + "compose" "kernel" create +"tuple" "kernel" lookup { { { "object" "kernel" } @@ -454,6 +508,10 @@ builtins get num-tags get tail f union-class define-class } } define-tuple-class +"compose" "kernel" lookup +dup f "inline" set-word-prop +dup tuple-layout [ ] curry define + ! Primitive words : make-primitive ( word vocab n -- ) >r create dup reset-word r> @@ -628,11 +686,10 @@ builtins get num-tags get tail f union-class define-class { "" "kernel" } { "(clone)" "kernel" } { "" "strings" } - { "(>tuple)" "tuples.private" } { "array>quotation" "quotations.private" } { "quotation-xt" "quotations" } { "" "tuples.private" } - { "tuple>array" "tuples" } + { "" "tuples.private" } { "profiling" "tools.profiler.private" } { "become" "kernel.private" } { "(sleep)" "threads.private" } diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index c21098916d..632af1d040 100755 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -39,15 +39,15 @@ HELP: sort-classes { $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ; HELP: class-or -{ $values { "class1" class } { "class2" class } { "class" class } } +{ $values { "first" class } { "second" class } { "class" class } } { $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; HELP: class-and -{ $values { "class1" class } { "class2" class } { "class" class } } +{ $values { "first" class } { "second" class } { "class" class } } { $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ; HELP: classes-intersect? -{ $values { "class1" class } { "class2" class } { "?" "a boolean" } } +{ $values { "first" class } { "second" class } { "?" "a boolean" } } { $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ; HELP: min-class diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 24a18559fe..cdf817e31d 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -51,7 +51,7 @@ UNION: both first-one union-class ; [ f ] [ \ reversed \ slice class< ] unit-test [ f ] [ \ slice \ reversed class< ] unit-test -PREDICATE: word no-docs "documentation" word-prop not ; +PREDICATE: no-docs < word "documentation" word-prop not ; UNION: no-docs-union no-docs integer ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 8f43aa3336..ae9e6ec154 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -28,7 +28,7 @@ M: union-1 generic-update-test drop "union-1" ; [ f ] [ union-1 number class< ] unit-test [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test -"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval +"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index e5039d8050..c2c19836cd 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -25,15 +25,15 @@ SYMBOL: class-or-cache class-and-cache get clear-assoc class-or-cache get clear-assoc ; -PREDICATE: word class ( obj -- ? ) "class" word-prop ; +PREDICATE: class < word ( obj -- ? ) "class" word-prop ; SYMBOL: update-map SYMBOL: builtins -PREDICATE: class builtin-class +PREDICATE: builtin-class < class "metaclass" word-prop builtin-class eq? ; -PREDICATE: class tuple-class +PREDICATE: tuple-class < class "metaclass" word-prop tuple-class eq? ; : classes ( -- seq ) all-words [ class? ] subset ; @@ -47,7 +47,7 @@ PREDICATE: class tuple-class : predicate-effect 1 { "?" } ; -PREDICATE: word predicate "predicating" word-prop >boolean ; +PREDICATE: predicate < word "predicating" word-prop >boolean ; : define-predicate ( class quot -- ) >r "predicate" word-prop first @@ -118,10 +118,3 @@ GENERIC: update-methods ( assoc -- ) GENERIC: class ( object -- class ) inline M: object class type type>class ; - - diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index f9b987eb78..780f76f0f8 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -4,7 +4,7 @@ USING: classes classes.union words kernel sequences definitions combinators arrays ; IN: classes.mixin -PREDICATE: union-class mixin-class "mixin" word-prop ; +PREDICATE: mixin-class < union-class "mixin" word-prop ; M: mixin-class reset-class { "metaclass" "members" "mixin" } reset-props ; diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor index a65392773d..d03d97cd4c 100755 --- a/core/classes/predicate/predicate-docs.factor +++ b/core/classes/predicate/predicate-docs.factor @@ -14,7 +14,7 @@ ARTICLE: "predicates" "Predicate classes" ABOUT: "predicates" HELP: define-predicate-class -{ $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } } +{ $values { "class" class } { "superclass" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } } { $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "class" } ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 6d1c727ee2..9f5961895a 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes kernel namespaces words ; IN: classes.predicate -PREDICATE: class predicate-class +PREDICATE: predicate-class < class "metaclass" word-prop predicate-class eq? ; : predicate-quot ( class -- quot ) @@ -13,8 +13,8 @@ PREDICATE: class predicate-class "predicate-definition" word-prop , [ drop f ] , \ if , ] [ ] make ; -: define-predicate-class ( superclass class definition -- ) - >r dup f roll predicate-class define-class r> +: define-predicate-class ( class superclass definition -- ) + >r >r dup f r> predicate-class define-class r> dupd "predicate-definition" set-word-prop dup predicate-quot define-predicate ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index c1c82d158b..3a791c22d0 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -4,7 +4,7 @@ USING: words sequences kernel assocs combinators classes generic.standard namespaces arrays math quotations ; IN: classes.union -PREDICATE: class union-class +PREDICATE: union-class < class "metaclass" word-prop union-class eq? ; ! Union classes for dispatch on multiple classes. diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 277a64225a..11f64c9373 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -15,7 +15,7 @@ IN: compiler.constants : byte-array-offset 2 bootstrap-cells object tag-number - ; : alien-offset 3 bootstrap-cells object tag-number - ; : underlying-alien-offset bootstrap-cell object tag-number - ; -: tuple-class-offset 2 bootstrap-cells tuple tag-number - ; +: tuple-class-offset bootstrap-cell tuple tag-number - ; : class-hash-offset bootstrap-cell object tag-number - ; : word-xt-offset 8 bootstrap-cells object tag-number - ; : word-code-offset 9 bootstrap-cells object tag-number - ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index cd6c8b61f7..8d1e1f281f 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -153,11 +153,11 @@ M: f v>operand drop \ f tag-number ; M: object load-literal v>operand load-indirect ; -PREDICATE: integer small-slot cells small-enough? ; +PREDICATE: small-slot < integer cells small-enough? ; -PREDICATE: integer small-tagged v>operand small-enough? ; +PREDICATE: small-tagged < integer v>operand small-enough? ; -PREDICATE: integer inline-array 32 < ; +PREDICATE: inline-array < integer 32 < ; : if-small-struct ( n size true false -- ? ) >r >r over not over struct-small-enough? and diff --git a/core/cpu/arm/assembler/assembler.factor b/core/cpu/arm/assembler/assembler.factor index d10b24de4e..5a69f93d85 100755 --- a/core/cpu/arm/assembler/assembler.factor +++ b/core/cpu/arm/assembler/assembler.factor @@ -27,7 +27,7 @@ SYMBOL: R15 { R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 } define-registers -PREDICATE: word register register >boolean ; +PREDICATE: register < word register >boolean ; GENERIC: register ( register -- n ) M: word register "register" word-prop ; diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 91bf5ed1e3..570cd42576 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -479,19 +479,17 @@ IN: cpu.ppc.intrinsics } define-intrinsic \ [ - tuple "n" get 2 + cells %allot - ! Store length - "n" operand 12 LI + tuple "layout" get layout-size 2 + cells %allot + ! Store layout + "layout" operand 12 LOAD32 12 11 cell STW - ! Store class - "class" operand 11 2 cells STW ! Zero out the rest of the tuple f v>operand 12 LI - "n" get 1- [ 12 11 rot 3 + cells STW ] each + "layout" get layout-size [ 12 11 rot 2 + cells STW ] each ! Store tagged ptr in reg "tuple" get tuple %store-tagged ] H{ - { +input+ { { f "class" } { [ inline-array? ] "n" } } } + { +input+ { { [ tuple-layout? ] "layout" } } { +scratch+ { { f "tuple" } } } { +output+ { "tuple" } } } define-intrinsic diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 81a7d7cd02..f4af421cdd 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -8,7 +8,7 @@ alien.compiler combinators command-line compiler compiler.units io vocabs.loader accessors ; IN: cpu.x86.32 -PREDICATE: x86-backend x86-32-backend +PREDICATE: x86-32-backend < x86-backend x86-backend-cell 4 = ; ! We implement the FFI for Linux, OS X and Windows all at once. diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 25e32225d4..c2af60e983 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -8,7 +8,7 @@ layouts alien alien.accessors alien.compiler alien.structs slots splitting assocs ; IN: cpu.x86.64 -PREDICATE: x86-backend amd64-backend +PREDICATE: amd64-backend < x86-backend x86-backend-cell 8 = ; M: amd64-backend ds-reg R14 ; diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 65caec412e..796388ffe1 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -52,13 +52,23 @@ GENERIC: extended? ( op -- ? ) M: object extended? drop f ; -PREDICATE: word register "register" word-prop ; +PREDICATE: register < word + "register" word-prop ; -PREDICATE: register register-8 "register-size" word-prop 8 = ; -PREDICATE: register register-16 "register-size" word-prop 16 = ; -PREDICATE: register register-32 "register-size" word-prop 32 = ; -PREDICATE: register register-64 "register-size" word-prop 64 = ; -PREDICATE: register register-128 "register-size" word-prop 128 = ; +PREDICATE: register-8 < register + "register-size" word-prop 8 = ; + +PREDICATE: register-16 < register + "register-size" word-prop 16 = ; + +PREDICATE: register-32 < register + "register-size" word-prop 32 = ; + +PREDICATE: register-64 < register + "register-size" word-prop 64 = ; + +PREDICATE: register-128 < register + "register-size" word-prop 128 = ; M: register extended? "register" word-prop 7 > ; @@ -285,7 +295,7 @@ GENERIC: (MOV-I) ( src dst -- ) M: register (MOV-I) t HEX: b8 short-operand cell, ; M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ; -PREDICATE: word callable register? not ; +PREDICATE: callable < word register? not ; GENERIC: MOV ( dst src -- ) M: integer MOV swap (MOV-I) ; diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 99a89eab05..dfe136fc6e 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -336,19 +336,20 @@ IN: cpu.x86.intrinsics } define-intrinsic \ [ - tuple "n" get 2 + cells [ - ! Store length - 1 object@ "n" operand MOV - ! Store class - 2 object@ "class" operand MOV + tuple "layout" get layout-size 2 + cells [ + ! Store layout + "layout" get "scratch" get load-literal + 1 object@ "scratch" operand MOV ! Zero out the rest of the tuple - "n" operand 1- [ 3 + object@ f v>operand MOV ] each + "layout" get layout-size [ + 2 + object@ f v>operand MOV + ] each ! Store tagged ptr in reg "tuple" get tuple %store-tagged ] %allot ] H{ - { +input+ { { f "class" } { [ inline-array? ] "n" } } } - { +scratch+ { { f "tuple" } } } + { +input+ { { [ tuple-layout? ] "layout" } } } + { +scratch+ { { f "tuple" } { f "scratch" } } } { +output+ { "tuple" } } } define-intrinsic diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 4775093ba7..3361073d35 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -156,7 +156,7 @@ M: relative-overflow summary : primitive-error. "Unimplemented primitive" print drop ; -PREDICATE: array kernel-error ( obj -- ? ) +PREDICATE: kernel-error < array { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 853a03d184..6a7f8f29fc 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -44,7 +44,7 @@ M: object funny drop 0 ; [ 2 ] [ [ { } ] funny ] unit-test [ 0 ] [ { } funny ] unit-test -PREDICATE: funnies very-funny number? ; +PREDICATE: very-funny < funnies number? ; GENERIC: gooey ( x -- y ) M: very-funny gooey sq ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 36ca0358b7..131b7e57c9 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -19,7 +19,8 @@ M: object perform-combination GENERIC: make-default-method ( generic combination -- method ) -PREDICATE: word generic "combination" word-prop >boolean ; +PREDICATE: generic < word + "combination" word-prop >boolean ; M: generic definition drop f ; @@ -30,7 +31,7 @@ M: generic definition drop f ; : method ( class generic -- method/f ) "methods" word-prop at ; -PREDICATE: pair method-spec +PREDICATE: method-spec < pair first2 generic? swap class? and ; : order ( generic -- seq ) @@ -55,7 +56,7 @@ TUPLE: check-method class generic ; : method-word-name ( class word -- string ) word-name "/" rot word-name 3append ; -PREDICATE: word method-body +PREDICATE: method-body < word "method-generic" word-prop >boolean ; M: method-body stack-effect diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 93c89af25c..85bd736139 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -5,7 +5,7 @@ math namespaces sequences words quotations layouts combinators sequences.private classes classes.algebra definitions ; IN: generic.math -PREDICATE: class math-class ( object -- ? ) +PREDICATE: math-class < class dup null bootstrap-word eq? [ drop f ] [ @@ -79,7 +79,7 @@ M: math-combination perform-combination ] if nip ] math-vtable nip ; -PREDICATE: generic math-generic ( word -- ? ) +PREDICATE: math-generic < generic ( word -- ? ) "combination" word-prop math-combination? ; M: math-generic definer drop \ MATH: f ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 4105a05cb1..4447c5a264 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -174,13 +174,13 @@ M: hook-combination perform-combination : define-simple-generic ( word -- ) T{ standard-combination f 0 } define-generic ; -PREDICATE: generic standard-generic +PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; -PREDICATE: standard-generic simple-generic +PREDICATE: simple-generic < standard-generic "combination" word-prop standard-combination-# zero? ; -PREDICATE: generic hook-generic +PREDICATE: hook-generic < generic "combination" word-prop hook-combination? ; GENERIC: dispatch# ( word -- n ) diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 23b5343c9c..0b6cf04028 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -102,7 +102,7 @@ TUPLE: #label word loop? ; : #label ( word label -- node ) \ #label param-node [ set-#label-word ] keep ; -PREDICATE: #label #loop #label-loop? ; +PREDICATE: #loop < #label #label-loop? ; TUPLE: #entry ; @@ -309,9 +309,9 @@ SYMBOL: node-stack DEFER: #tail? -PREDICATE: #merge #tail-merge node-successor #tail? ; +PREDICATE: #tail-merge < #merge node-successor #tail? ; -PREDICATE: #values #tail-values node-successor #tail? ; +PREDICATE: #tail-values < #values node-successor #tail? ; UNION: #tail POSTPONE: f #return #tail-values #tail-merge #terminate ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 08fb56ced7..0de1e0bc53 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -135,7 +135,7 @@ M: object infer-call ! Variadic tuple constructor \ [ \ - peek-d value-literal { tuple } + peek-d value-literal layout-size { tuple } make-call-node ] "infer" set-word-prop @@ -565,14 +565,11 @@ set-primitive-effect \ quotation-xt { quotation } { integer } set-primitive-effect \ quotation-xt make-flushable -\ { word integer } { quotation } set-primitive-effect +\ { tuple-layout } { tuple } set-primitive-effect \ make-flushable -\ (>tuple) { array } { tuple } set-primitive-effect -\ (>tuple) make-flushable - -\ tuple>array { tuple } { array } set-primitive-effect -\ tuple>array make-flushable +\ { word fixnum array fixnum } { tuple-layout } set-primitive-effect +\ make-foldable \ datastack { } { array } set-primitive-effect \ datastack make-flushable diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index a829bad47e..b3a2bffcfe 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -76,7 +76,7 @@ M: duplicated-slots-error summary \ construct-boa [ dup +inlined+ depends-on - dup tuple-size [ ] 2curry + tuple-layout [ ] curry ] 1 define-transform \ construct-empty [ @@ -84,7 +84,7 @@ M: duplicated-slots-error summary peek-d value? [ pop-literal dup +inlined+ depends-on - dup tuple-size [ ] 2curry + tuple-layout [ ] curry swap infer-quot ] [ \ construct-empty 1 1 make-call-node diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor index 73d2efa7d4..397d1ea89c 100755 --- a/core/io/encodings/encodings-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -6,7 +6,7 @@ IN: io.streams.encodings.tests resource-path ascii ; [ { } ] -[ "/core/io/test/empty-file.txt" lines ] +[ "core/io/test/empty-file.txt" lines ] unit-test : lines-test ( stream -- line1 line2 ) @@ -16,21 +16,21 @@ unit-test "This is a line." "This is another line." ] [ - "/core/io/test/windows-eol.txt" lines-test + "core/io/test/windows-eol.txt" lines-test ] unit-test [ "This is a line." "This is another line." ] [ - "/core/io/test/mac-os-eol.txt" lines-test + "core/io/test/mac-os-eol.txt" lines-test ] unit-test [ "This is a line." "This is another line." ] [ - "/core/io/test/unix-eol.txt" lines-test + "core/io/test/unix-eol.txt" lines-test ] unit-test [ diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index abae63c82b..b7d1cf81c8 100755 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -4,7 +4,7 @@ io.encodings.binary ; IN: io.tests [ f ] [ - "resource:/core/io/test/no-trailing-eol.factor" run-file + "resource:core/io/test/no-trailing-eol.factor" run-file "foo" "io.tests" lookup ] unit-test @@ -14,14 +14,14 @@ IN: io.tests [ "This is a line.\rThis is another line.\r" ] [ - "/core/io/test/mac-os-eol.txt" + "core/io/test/mac-os-eol.txt" [ 500 read ] with-stream ] unit-test [ 255 ] [ - "/core/io/test/binary.txt" + "core/io/test/binary.txt" [ read1 ] with-stream >fixnum ] unit-test @@ -36,7 +36,7 @@ IN: io.tests } ] [ [ - "/core/io/test/separator-test.txt" [ + "core/io/test/separator-test.txt" [ "J" read-until 2array , "i" read-until 2array , "X" read-until 2array , diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 61574e406f..2d99f0793b 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -67,29 +67,7 @@ DEFER: if [ >r tuck 2slip r> while ] [ 2nip call ] if ; inline -! Quotation building -USE: tuples.private - -: curry ( obj quot -- curry ) - \ curry 4 ; - -: 2curry ( obj1 obj2 quot -- curry ) - curry curry ; inline - -: 3curry ( obj1 obj2 obj3 quot -- curry ) - curry curry curry ; inline - -: with ( param obj quot -- obj curry ) - swapd [ swapd call ] 2curry ; inline - -: compose ( quot1 quot2 -- curry ) - \ compose 4 ; - -: 3compose ( quot1 quot2 quot3 -- curry ) - compose compose ; inline - ! Object protocol - GENERIC: delegate ( obj -- delegate ) M: object delegate drop f ; @@ -118,7 +96,6 @@ M: object clone ; M: callstack clone (clone) ; ! Tuple construction - GENERIC# get-slots 1 ( tuple slots -- ... ) GENERIC# set-slots 1 ( ... tuple slots -- ) @@ -132,8 +109,22 @@ GENERIC: construct-boa ( ... class -- tuple ) : construct-delegate ( delegate class -- tuple ) >r { set-delegate } r> construct ; inline -! Booleans +! Quotation building +USE: tuples.private +: 2curry ( obj1 obj2 quot -- curry ) + curry curry ; inline + +: 3curry ( obj1 obj2 obj3 quot -- curry ) + curry curry curry ; inline + +: with ( param obj quot -- obj curry ) + swapd [ swapd call ] 2curry ; inline + +: 3compose ( quot1 quot2 quot3 -- curry ) + compose compose ; inline + +! Booleans : not ( obj -- ? ) f eq? ; inline : >boolean ( obj -- ? ) t f ? ; inline diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 0a3442566c..b56f6fdb06 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -11,12 +11,11 @@ classes.algebra optimizer.def-use optimizer.backend optimizer.pattern-match optimizer.inlining float-arrays sequences.private combinators ; -! the output of and has the class which is -! its second-to-last input { } [ [ - dup node-in-d dup length 2 - swap nth node-literal - dup class? [ drop tuple ] unless 1array f + dup node-in-d peek node-literal + dup tuple-layout? [ layout-class ] [ drop tuple ] if + 1array f ] "output-classes" set-word-prop ] each diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index f024eda54c..670740fff0 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -389,7 +389,7 @@ IN: parser.tests ] with-scope [ ] [ - "IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval + "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval ] unit-test [ t ] [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 28822db708..bb3ad254da 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -214,7 +214,7 @@ SYMBOL: in ERROR: unexpected want got ; -PREDICATE: unexpected unexpected-eof +PREDICATE: unexpected-eof < unexpected unexpected-got not ; : unexpected-eof ( word -- * ) f unexpected ; @@ -288,6 +288,14 @@ M: no-word summary : CREATE-METHOD ( -- method ) scan-word bootstrap-word scan-word create-method-in ; +: parse-tuple-definition ( -- class superclass slots ) + CREATE-CLASS + scan { + { ";" [ tuple f ] } + { "<" [ scan-word ";" parse-tokens ] } + [ >r tuple ";" parse-tokens r> add* ] + } case ; + ERROR: staging-violation word ; M: staging-violation summary diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 226595aa4d..5d7b967fc4 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -4,7 +4,7 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors generic hashtables io assocs kernel math namespaces sequences strings sbufs io.styles vectors words prettyprint.config prettyprint.sections quotations io io.files math.parser effects -tuples classes float-arrays float-vectors ; +tuples tuples.private classes float-arrays float-vectors ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -202,3 +202,6 @@ M: wrapper pprint* ] [ pprint-object ] if ; + +M: tuple-layout pprint* + "( tuple layout )" swap present-text ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 8df97effb6..35b30ac46f 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -329,3 +329,9 @@ M: f generic-see-test-with-f ; [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [ [ \ f \ generic-see-test-with-f method see ] with-string-writer ] unit-test + +PREDICATE: predicate-see-test < integer even? ; + +[ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [ + [ \ predicate-see-test see ] with-string-writer +] unit-test diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 8bce81650f..7b8c8f2997 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -247,8 +247,9 @@ M: mixin-class see-class* M: predicate-class see-class* block> ; @@ -256,6 +257,9 @@ M: predicate-class see-class* M: tuple-class see-class* ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 65c6da2b06..693e337959 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -7,9 +7,9 @@ IN: quotations M: quotation call (call) ; -M: curry call dup 4 slot swap 5 slot call ; +M: curry call dup 3 slot swap 4 slot call ; -M: compose call dup 4 slot swap 5 slot slip call ; +M: compose call dup 3 slot swap 4 slot slip call ; M: wrapper equal? over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 14674ba2f2..111cf74ea2 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -60,7 +60,7 @@ INSTANCE: immutable-sequence sequence #! A bit of a pain; can't call cell-bits here 7 getenv 8 * 5 - 2^ 1- ; foldable -PREDICATE: fixnum array-capacity +PREDICATE: array-capacity < fixnum 0 max-array-capacity between? ; : array-capacity ( array -- n ) diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index cc93aeeff2..2ec8f3d0d1 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -8,7 +8,7 @@ IN: slots.deprecated : reader-effect ( class spec -- effect ) >r ?word-name 1array r> slot-spec-name 1array ; -PREDICATE: word slot-reader "reading" word-prop >boolean ; +PREDICATE: slot-reader < word "reading" word-prop >boolean ; : set-reader-props ( class spec -- ) 2dup reader-effect @@ -30,7 +30,7 @@ PREDICATE: word slot-reader "reading" word-prop >boolean ; : writer-effect ( class spec -- effect ) slot-spec-name swap ?word-name 2array 0 ; -PREDICATE: word slot-writer "writing" word-prop >boolean ; +PREDICATE: slot-writer < word "writing" word-prop >boolean ; : set-writer-props ( class spec -- ) 2dup writer-effect diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index e4bb307829..5de765313b 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -12,7 +12,7 @@ ARTICLE: "accessors" "Slot accessors" } "In addition, two utility words are defined for each distinct slot name used in the system:" { $list - { "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." } + { "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." } { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." } } "Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names." diff --git a/core/slots/slots.factor b/core/slots/slots.factor index ed5de3a439..dfd5c1b32a 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -46,7 +46,7 @@ C: slot-spec : define-writer ( class slot name -- ) writer-word [ set-slot ] define-slot-word ; -: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline +: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline : setter-word ( name -- word ) ">>" prepend setter-effect create-accessor ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index c0ceb4119a..3874cecf71 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -543,8 +543,8 @@ HELP: INSTANCE: { $description "Makes " { $snippet "instance" } " an instance of " { $snippet "mixin" } "." } ; HELP: PREDICATE: -{ $syntax "PREDICATE: superclass class predicate... ;" } -{ $values { "superclass" "an existing class word" } { "class" "a new class word to define" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } } +{ $syntax "PREDICATE: class < superclass predicate... ;" } +{ $values { "class" "a new class word to define" } { "superclass" "an existing class word" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } } { $description "Defines a predicate class deriving from " { $snippet "superclass" } "." $nl @@ -557,11 +557,9 @@ HELP: PREDICATE: } ; HELP: TUPLE: -{ $syntax "TUPLE: class slots... ;" } +{ $syntax "TUPLE: class slots... ;" "TUPLE: class < superclass slots ... ;" } { $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } } -{ $description "Defines a new tuple class." -$nl -"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ; +{ $description "Defines a new tuple class. The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." } ; HELP: ERROR: { $syntax "ERROR: class slots... ;" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 843f372542..9190b9676d 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -6,7 +6,7 @@ namespaces parser sequences strings sbufs vectors words quotations io assocs splitting tuples generic.standard generic.math classes io.files vocabs float-arrays float-vectors classes.union classes.mixin classes.predicate compiler.units -combinators ; +combinators debugger ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -148,13 +148,14 @@ IN: bootstrap.syntax ] define-syntax "PREDICATE:" [ - scan-word CREATE-CLASS + scan "<" assert= + scan-word parse-definition define-predicate-class ] define-syntax "TUPLE:" [ - CREATE-CLASS ";" parse-tokens define-tuple-class + parse-tuple-definition define-tuple-class ] define-syntax "C:" [ @@ -164,9 +165,9 @@ IN: bootstrap.syntax ] define-syntax "ERROR:" [ - CREATE-CLASS dup ";" parse-tokens define-tuple-class - dup save-location - dup [ construct-boa throw ] curry define + parse-tuple-definition + pick save-location + define-error-class ] define-syntax "FORGET:" [ diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 09d93884ad..6e0f319c9a 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -153,10 +153,6 @@ HELP: tuple= { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } { $warning "This word is in the " { $vocab-link "tuples.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ; -HELP: tuple-class-eq? -{ $values { "obj" object } { "class" tuple-class } { "?" "a boolean" } } -{ $description "Tests if " { $snippet "obj" } " is an instance of " { $snippet "class" } "." } ; - 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" } "." } ; @@ -169,7 +165,7 @@ HELP: reshape-tuples { $values { "class" tuple-class } { "newslots" "a sequence of strings" } } { $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ; -HELP: old-slots +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" } "." } ; @@ -194,8 +190,8 @@ HELP: define-tuple-predicate { $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." } $low-level-note ; -HELP: check-shape -{ $values { "class" class } { "newslots" "a sequence of strings" } } +HELP: redefine-tuple-class +{ $values { "class" class } { "superclass" class } { "newslots" "a sequence of strings" } } { $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed." $nl "If the class is not a tuple class word, this word does nothing." } @@ -218,8 +214,8 @@ HELP: check-tuple { $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ; HELP: define-tuple-class -{ $values { "class" word } { "slots" "a sequence of strings" } } -{ $description "Defines a tuple class with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." } +{ $values { "class" word } { "superclass" class } { "slots" "a sequence of strings" } } +{ $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } { $side-effects "class" } ; @@ -246,9 +242,13 @@ HELP: tuple>array ( tuple -- array ) { $values { "tuple" tuple } { "array" array } } { $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ; -HELP: ( class n -- tuple ) -{ $values { "class" tuple-class } { "n" "a non-negative integer" } { "tuple" tuple } } -{ $description "Low-level tuple constructor. User code should never call this directly, and instead use the constructor word which is defined for each tuple. See " { $link "tuples" } "." } ; +HELP: ( layout -- tuple ) +{ $values { "layout" tuple-layout } { "tuple" tuple } } +{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ; + +HELP: ( ... layout -- tuple ) +{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } } +{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ; HELP: construct-empty { $values { "class" tuple-class } { "tuple" tuple } } diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index fec3bdbc6f..2d28697b70 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -2,18 +2,19 @@ USING: definitions generic kernel kernel.private math math.constants parser sequences tools.test words assocs namespaces quotations sequences.private classes continuations generic.standard effects tuples tuples.private arrays vectors -strings compiler.units ; +strings compiler.units accessors classes.algebra calendar +prettyprint io.streams.string splitting ; IN: tuples.tests TUPLE: rect x y w h ; : rect construct-boa ; -: move ( x rect -- ) - [ rect-x + ] keep set-rect-x ; +: move ( x rect -- rect ) + [ + ] change-x ; -[ f ] [ 10 20 30 40 dup clone 5 swap [ move ] keep = ] unit-test +[ f ] [ 10 20 30 40 dup clone 5 swap move = ] unit-test -[ t ] [ 10 20 30 40 dup clone 0 swap [ move ] keep = ] unit-test +[ t ] [ 10 20 30 40 dup clone 0 swap move = ] unit-test GENERIC: delegation-test M: object delegation-test drop 3 ; @@ -34,27 +35,46 @@ TUPLE: quuux-tuple-2 ; [ 4 ] [ delegation-test-2 ] unit-test +! Make sure we handle tuple class redefinition +TUPLE: redefinition-test ; + +C: redefinition-test + + "redefinition-test" set + +[ t ] [ "redefinition-test" get redefinition-test? ] unit-test + +"IN: tuples.tests TUPLE: redefinition-test ;" eval + +[ t ] [ "redefinition-test" get redefinition-test? ] unit-test + ! Make sure we handle changing shapes! TUPLE: point x y ; C: point -100 200 "p" set +[ ] [ 100 200 "p" set ] unit-test ! Use eval to sequence parsing explicitly -"IN: tuples.tests TUPLE: point x y z ;" eval +[ ] [ "IN: tuples.tests TUPLE: point x y z ;" eval ] unit-test -[ 100 ] [ "p" get point-x ] unit-test -[ 200 ] [ "p" get point-y ] unit-test -[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test +[ 100 ] [ "p" get x>> ] unit-test +[ 200 ] [ "p" get y>> ] unit-test +[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -300 "p" get "set-point-z" "tuples.tests" lookup execute +"p" get 300 ">>z" "accessors" lookup execute drop + +[ 4 ] [ "p" get tuple-size ] unit-test + +[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test "IN: tuples.tests TUPLE: point z y ;" eval -[ "p" get point-x ] must-fail -[ 200 ] [ "p" get point-y ] unit-test -[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test +[ 3 ] [ "p" get tuple-size ] unit-test + +[ "p" get x>> ] must-fail +[ 200 ] [ "p" get y>> ] unit-test +[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test TUPLE: predicate-test ; @@ -64,14 +84,14 @@ C: predicate-test [ t ] [ predicate-test? ] unit-test -PREDICATE: tuple silly-pred +PREDICATE: silly-pred < tuple class \ rect = ; GENERIC: area -M: silly-pred area dup rect-w swap rect-h * ; +M: silly-pred area dup w>> swap h>> * ; TUPLE: circle radius ; -M: circle area circle-radius sq pi * ; +M: circle area radius>> sq pi * ; [ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test @@ -88,7 +108,7 @@ TUPLE: delegate-clone ; [ T{ delegate-clone T{ empty f } } clone ] unit-test ! Compiler regression -[ t length ] [ no-method-object t eq? ] must-fail-with +[ t length ] [ object>> t eq? ] must-fail-with [ "" ] [ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test @@ -96,7 +116,7 @@ TUPLE: delegate-clone ; TUPLE: size-test a b c d ; [ t ] [ - T{ size-test } array-capacity + T{ size-test } tuple-size size-test tuple-size = ] unit-test @@ -213,22 +233,69 @@ C: erg's-reshape-problem ! tuples are reshaped : cons-test-1 \ erg's-reshape-problem construct-empty ; : cons-test-2 \ erg's-reshape-problem construct-boa ; -: cons-test-3 - { set-erg's-reshape-problem-a } - \ erg's-reshape-problem construct ; "IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test -[ t ] [ cons-test-1 array-capacity "a" get array-capacity = ] unit-test - -[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test +[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test [ "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval ] [ [ no-tuple-class? ] is? ] must-fail-with +! Inheritance +TUPLE: computer cpu ram ; + +[ "TUPLE: computer cpu ram ;" ] [ + [ \ computer see ] with-string-writer string-lines second +] unit-test + +TUPLE: laptop < computer battery ; +C: laptop + +[ t ] [ laptop tuple-class? ] unit-test +[ t ] [ laptop tuple class< ] unit-test +[ t ] [ laptop computer class< ] unit-test +[ t ] [ laptop computer classes-intersect? ] unit-test + +[ ] [ "Pentium" 128 3 hours "laptop" set ] unit-test +[ t ] [ "laptop" get laptop? ] unit-test +[ t ] [ "laptop" get computer? ] unit-test +[ t ] [ "laptop" get tuple? ] unit-test + +[ "TUPLE: laptop < computer battery ;" ] [ + [ \ laptop see ] with-string-writer string-lines second +] unit-test + +TUPLE: server < computer rackmount? ; +C: server + +[ t ] [ server tuple-class? ] unit-test +[ t ] [ server tuple class< ] unit-test +[ t ] [ server computer class< ] unit-test +[ t ] [ server computer classes-intersect? ] unit-test + +[ ] [ "Pentium" 128 "1U" "server" set ] unit-test +[ t ] [ "server" get server? ] unit-test +[ t ] [ "server" get computer? ] unit-test +[ t ] [ "server" get tuple? ] unit-test + +[ f ] [ "server" get laptop? ] unit-test +[ f ] [ "laptop" get server? ] unit-test + +[ f ] [ server laptop class< ] unit-test +[ f ] [ laptop server class< ] unit-test +[ f ] [ laptop server classes-intersect? ] unit-test + +[ "TUPLE: server < computer rackmount? ;" ] [ + [ \ server see ] with-string-writer string-lines second +] unit-test + +[ + "IN: tuples.tests TUPLE: bad-superclass < word ;" eval +] must-fail + ! Hardcore unit tests USE: threads @@ -236,14 +303,14 @@ USE: threads [ ] [ [ - \ thread { "xxx" } "slot-names" get append + \ thread tuple { "xxx" } "slot-names" get append define-tuple-class ] with-compilation-unit [ 1337 sleep ] "Test" spawn drop [ - \ thread "slot-names" get + \ thread tuple "slot-names" get define-tuple-class ] with-compilation-unit ] unit-test @@ -254,14 +321,14 @@ USE: vocabs [ ] [ [ - \ vocab { "xxx" } "slot-names" get append + \ vocab tuple { "xxx" } "slot-names" get append define-tuple-class ] with-compilation-unit all-words drop [ - \ vocab "slot-names" get + \ vocab tuple "slot-names" get define-tuple-class ] with-compilation-unit ] unit-test diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 02ce49d779..83f398242a 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -1,31 +1,91 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic -classes classes.private slots slots.deprecated slots.private +classes classes.private slots.deprecated slots.private slots compiler.units ; IN: tuples -M: tuple delegate 3 slot ; +M: tuple delegate 2 slot ; -M: tuple set-delegate 3 set-slot ; +M: tuple set-delegate 2 set-slot ; -M: tuple class class-of-tuple ; +M: tuple class 1 slot 2 slot { word } declare ; + +ERROR: no-tuple-class class ; + + + +: check-tuple ( class -- ) + dup tuple-class? + [ drop ] [ no-tuple-class ] if ; + +: tuple>array ( tuple -- array ) + dup tuple-layout + [ layout-size swap [ array-nth ] curry map ] keep + layout-class add* ; + +: >tuple ( sequence -- tuple ) + dup first tuple-layout [ + >r 1 tail-slice dup length r> + [ tuple-size min ] keep + [ set-array-nth ] curry + 2each + ] keep ; r over r> array-nth >r array-nth r> = ] 2curry all-integers? ] [ - 3drop f + 2drop f ] if ; -: tuple-class-eq? ( obj class -- ? ) - over tuple? [ swap 2 slot eq? ] [ 2drop f ] if ; inline +M: tuple-class tuple-layout "layout" word-prop ; + +: define-tuple-predicate ( class -- ) + dup tuple-layout + [ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry + define-predicate ; + +: delegate-slot-spec + T{ slot-spec f + object + "delegate" + 2 + delegate + set-delegate + } ; + +: define-tuple-slots ( class slots -- ) + dupd 3 simple-slots + 2dup [ slot-spec-name ] map "slot-names" set-word-prop + 2dup delegate-slot-spec add* "slots" set-word-prop + 2dup define-slots + define-accessors ; + +: define-tuple-layout ( class -- ) + dup + dup "slot-names" word-prop length 1+ { } 0 + "layout" set-word-prop ; + +: removed-slots ( class newslots -- seq ) + swap "slot-names" word-prop seq-diff ; + +: forget-slots ( class newslots -- ) + dupd removed-slots [ + 2dup + reader-word forget-method + writer-word forget-method + ] with each ; : permutation ( seq1 seq2 -- permutation ) swap [ index ] curry map ; @@ -33,7 +93,7 @@ M: tuple class class-of-tuple ; : reshape-tuple ( oldtuple permutation -- newtuple ) >r tuple>array 2 cut r> [ [ swap ?nth ] [ drop f ] if* ] with map - append (>tuple) ; + append >tuple ; : reshape-tuples ( class newslots -- ) >r dup "slot-names" word-prop r> permutation @@ -43,63 +103,40 @@ M: tuple class class-of-tuple ; become ] 2curry after-compilation ; -: old-slots ( class newslots -- seq ) - swap "slots" word-prop 1 tail-slice - [ slot-spec-name swap member? not ] with subset ; +: tuple-class-unchanged ( class superclass slots -- ) 3drop ; -: forget-slots ( class newslots -- ) - dupd old-slots [ - 2dup - slot-spec-reader 2array forget - slot-spec-writer 2array forget - ] with each ; +: prepare-tuple-class ( class slots -- ) + dupd define-tuple-slots + dup define-tuple-layout + define-tuple-predicate ; -: check-shape ( class newslots -- ) - over tuple-class? [ - over "slot-names" word-prop over = [ - 2dup forget-slots - 2dup reshape-tuples - over changed-word - over redefined - ] unless - ] when 2drop ; +: change-superclass "not supported" throw ; -GENERIC: tuple-size ( class -- size ) +: redefine-tuple-class ( class superclass slots -- ) + >r 2dup swap superclass eq? + [ drop ] [ dupd change-superclass ] if r> + 2dup forget-slots + 2dup reshape-tuples + over changed-word + over redefined + prepare-tuple-class ; -M: tuple-class tuple-size "slot-names" word-prop length 2 + ; +: define-new-tuple-class ( class superclass slots -- ) + >r dupd f swap tuple-class define-class r> + prepare-tuple-class ; PRIVATE> -: define-tuple-predicate ( class -- ) - dup [ tuple-class-eq? ] curry define-predicate ; +: define-tuple-class ( class superclass slots -- ) + { + { [ pick tuple-class? not ] [ define-new-tuple-class ] } + { [ pick "slot-names" word-prop over = ] [ tuple-class-unchanged ] } + { [ t ] [ redefine-tuple-class ] } + } cond ; -: delegate-slot-spec - T{ slot-spec f - object - "delegate" - 3 - delegate - set-delegate - } ; - -: define-tuple-slots ( class slots -- ) - dupd 4 simple-slots - 2dup [ slot-spec-name ] map "slot-names" set-word-prop - 2dup delegate-slot-spec add* "slots" set-word-prop - 2dup define-slots - define-accessors ; - -ERROR: no-tuple-class class ; - -: check-tuple ( class -- ) - dup tuple-class? - [ drop ] [ no-tuple-class ] if ; - -: define-tuple-class ( class slots -- ) - 2dup check-shape - over f tuple tuple-class define-class - over define-tuple-predicate - define-tuple-slots ; +: define-error-class ( class superclass slots -- ) + pick >r define-tuple-class r> + dup [ construct-boa throw ] curry define ; M: tuple clone (clone) dup delegate clone over set-delegate ; @@ -107,21 +144,14 @@ M: tuple clone M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; -: (delegates) ( obj -- ) - [ dup , delegate (delegates) ] when* ; - : delegates ( obj -- seq ) [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; : is? ( obj quot -- ? ) >r delegates r> contains? ; inline -: >tuple ( seq -- tuple ) - >vector dup first tuple-size over set-length - >array (>tuple) ; - M: tuple hashcode* [ - dup array-capacity -rot 0 -rot [ + dup tuple-size -rot 0 -rot [ swapd array-nth hashcode* bitxor ] 2curry reduce ] recursive-hashcode ; @@ -131,7 +161,7 @@ M: tuple hashcode* ! Definition protocol M: tuple-class reset-class { - "metaclass" "superclass" "slot-names" "slots" + "metaclass" "superclass" "slot-names" "slots" "layout" } reset-props ; M: object get-slots ( obj slots -- ... ) @@ -141,10 +171,10 @@ M: object set-slots ( ... obj slots -- ) get-slots ; M: object construct-empty ( class -- tuple ) - dup tuple-size ; + tuple-layout ; M: object construct ( ... slots class -- tuple ) construct-empty [ swap set-slots ] keep ; M: object construct-boa ( ... class -- tuple ) - dup tuple-size ; + tuple-layout ; diff --git a/core/words/words.factor b/core/words/words.factor index de253e6fee..5c0d84d4cc 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -23,17 +23,17 @@ M: word definition word-def ; ERROR: undefined ; -PREDICATE: word deferred ( obj -- ? ) +PREDICATE: deferred < word ( obj -- ? ) word-def [ undefined ] = ; M: deferred definer drop \ DEFER: f ; M: deferred definition drop f ; -PREDICATE: word symbol ( obj -- ? ) +PREDICATE: symbol < word ( obj -- ? ) dup 1array swap word-def sequence= ; M: symbol definer drop \ SYMBOL: f ; M: symbol definition drop f ; -PREDICATE: word primitive ( obj -- ? ) +PREDICATE: primitive < word ( obj -- ? ) word-def [ do-primitive ] tail? ; M: primitive definer drop \ PRIMITIVE: f ; M: primitive definition drop f ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index 0e26abe02f..bb0d16c9da 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,6 +1,6 @@ USING: kernel system namespaces sequences splitting combinators - io.files io.launcher + io io.files io.launcher bake combinators.cleave builder.common builder.util ; IN: builder.release @@ -91,6 +91,39 @@ IN: builder.release : remove-factor-app ( -- ) macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: upload-to-factorcode + +: platform ( -- string ) { os cpu- } to-strings "-" join ; + +: remote-location ( -- dest ) + "factorcode.org:/var/www/factorcode.org/newsite/downloads" + platform + append-path ; + +: upload ( -- ) + { "scp" archive-name remote-location } to-strings + [ "Error uploading binary to factorcode" print ] + run-or-bail ; + +: maybe-upload ( -- ) + upload-to-factorcode get + [ upload ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : release ( -- ) +! "factor" +! [ +! remove-factor-app +! remove-common-files +! ] +! with-directory +! make-archive +! archive-name releases move-file-into ; + : release ( -- ) "factor" [ @@ -99,6 +132,7 @@ IN: builder.release ] with-directory make-archive + maybe-upload archive-name releases move-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 459938c885..9fe19555c5 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman, -! Eduardo Cavazos, Daniel Ehrenberg. +! Copyright (C) 2007, 2008 Slava Pestov, Chris Double, +! Doug Coleman, Eduardo Cavazos, +! Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel combinators namespaces quotations hashtables +USING: kernel combinators fry namespaces quotations hashtables sequences assocs arrays inference effects math math.ranges arrays.lib shuffle macros bake combinators.cleave continuations ; @@ -34,9 +35,8 @@ MACRO: nwith ( quot n -- ) MACRO: napply ( n -- ) 2 [a,b] - [ [ ] [ 1- ] bi - [ , ntuck , nslip ] - bake ] + [ [ 1- ] [ ] bi + '[ , ntuck , nslip ] ] map concat >quotation [ call ] append ; : 3apply ( obj obj obj quot -- ) 3 napply ; inline @@ -88,26 +88,21 @@ MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ; ! ifte ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +MACRO: preserving ( predicate -- quot ) + dup infer effect-in + dup 1+ + '[ , , nkeep , nrot ] ; + MACRO: ifte ( quot quot quot -- ) - pick infer effect-in - dup 1+ swap - [ >r >r , nkeep , nrot r> r> if ] - bake ; + '[ , preserving , , if ] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! switch ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: preserving ( predicate -- quot ) - dup infer effect-in - dup 1+ spin - [ , , nkeep , nrot ] - bake ; - MACRO: switch ( quot -- ) - [ [ preserving ] [ ] bi* ] assoc-map - [ , cond ] - bake ; + [ [ [ preserving ] curry ] dip ] assoc-map + [ cond ] curry ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 67b8a39320..7f24d6258f 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -10,7 +10,7 @@ IN: delegate CREATE-WORD dup define-symbol parse-definition swap define-protocol ; parsing -PREDICATE: word protocol "protocol-words" word-prop ; +PREDICATE: protocol < word "protocol-words" word-prop ; GENERIC: group-words ( group -- words ) diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 9c3615f629..5dc7255eed 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -14,7 +14,7 @@ IN: help.markup ! Element types are words whose name begins with $. -PREDICATE: array simple-element +PREDICATE: simple-element < array dup empty? [ drop t ] [ first word? not ] if ; SYMBOL: last-element diff --git a/extra/help/topics/topics.factor b/extra/help/topics/topics.factor index 4a86d49a28..c12c392eb3 100755 --- a/extra/help/topics/topics.factor +++ b/extra/help/topics/topics.factor @@ -16,7 +16,7 @@ M: link >link ; M: vocab-spec >link ; M: object >link link construct-boa ; -PREDICATE: link word-link link-name word? ; +PREDICATE: word-link < link link-name word? ; M: link summary [ diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 4bb620083f..1468065ebe 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -54,9 +54,9 @@ M: no-inverse summary : undo-literal ( object -- quot ) [ =/fail ] curry ; -PREDICATE: word normal-inverse "inverse" word-prop ; -PREDICATE: word math-inverse "math-inverse" word-prop ; -PREDICATE: word pop-inverse "pop-length" word-prop ; +PREDICATE: normal-inverse < word "inverse" word-prop ; +PREDICATE: math-inverse < word "math-inverse" word-prop ; +PREDICATE: pop-inverse < word "pop-length" word-prop ; UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; : inline-word ( word -- ) diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor old mode 100644 new mode 100755 index c041e699a2..afa35e4181 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -54,10 +54,8 @@ IN: io.encodings.8-bit [ byte>ch ] [ ch>byte ] bi ; : empty-tuple-class ( string -- class ) - in get create - dup { f } "slots" set-word-prop - dup predicate-word drop - dup { } define-tuple-class ; + "io.encodings.8-bit" create + dup tuple { } define-tuple-class ; : data-quot ( class word data -- quot ) >r [ word-name ] 2apply "/" swap 3append diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 8f5babeff7..ed98665e06 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -22,8 +22,8 @@ M: port set-timeout set-port-timeout ; SYMBOL: closed -PREDICATE: port input-port port-type input-port eq? ; -PREDICATE: port output-port port-type output-port eq? ; +PREDICATE: input-port < port port-type input-port eq? ; +PREDICATE: output-port < port port-type output-port eq? ; GENERIC: init-handle ( handle -- ) GENERIC: close-handle ( handle -- ) diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 640ae0c9ea..455f39d2b5 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -29,23 +29,23 @@ TUPLE: wlet bindings body ; C: wlet -PREDICATE: word local "local?" word-prop ; +PREDICATE: local < word "local?" word-prop ; : ( name -- word ) #! Create a local variable identifier f dup t "local?" set-word-prop ; -PREDICATE: word local-word "local-word?" word-prop ; +PREDICATE: local-word < word "local-word?" word-prop ; : ( name -- word ) f dup t "local-word?" set-word-prop ; -PREDICATE: word local-reader "local-reader?" word-prop ; +PREDICATE: local-reader < word "local-reader?" word-prop ; : ( name -- word ) f dup t "local-reader?" set-word-prop ; -PREDICATE: word local-writer "local-writer?" word-prop ; +PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) dup word-name "!" append f @@ -357,7 +357,7 @@ M: wlet pprint* \ [wlet pprint-let ; M: let* pprint* \ [let* pprint-let ; -PREDICATE: word lambda-word +PREDICATE: lambda-word < word "lambda" word-prop >boolean ; M: lambda-word definer drop \ :: \ ; ; @@ -373,7 +373,7 @@ M: lambda-word definition M: lambda-word synopsis* lambda-word-synopsis ; -PREDICATE: macro lambda-macro +PREDICATE: lambda-macro < macro "lambda" word-prop >boolean ; M: lambda-macro definer drop \ MACRO:: \ ; ; @@ -383,7 +383,7 @@ M: lambda-macro definition M: lambda-macro synopsis* lambda-word-synopsis ; -PREDICATE: method-body lambda-method +PREDICATE: lambda-method < method-body "lambda" word-prop >boolean ; M: lambda-method definer drop \ M:: \ ; ; diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor index 87b3acd47c..b242f91d3b 100755 --- a/extra/macros/macros.factor +++ b/extra/macros/macros.factor @@ -17,7 +17,7 @@ IN: macros : MACRO: (:) define-macro ; parsing -PREDICATE: word macro "macro" word-prop >boolean ; +PREDICATE: macro < word "macro" word-prop >boolean ; M: macro definer drop \ MACRO: \ ; ; diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index ab915ae7d5..45ae2cc959 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -42,7 +42,7 @@ IN: memoize : MEMO: CREATE-WORD parse-definition define-memoized ; parsing -PREDICATE: word memoized "memoize" word-prop ; +PREDICATE: memoized < word "memoize" word-prop ; M: memoized definer drop \ MEMO: \ ; ; M: memoized definition "memo-quot" word-prop ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 42ade34186..ed82d2478e 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -64,7 +64,8 @@ GENERIC: method-prologue ( combination -- quot ) TUPLE: method word def classes generic loc ; -PREDICATE: word method-body "multi-method" word-prop >boolean ; +PREDICATE: method-body < word + "multi-method" word-prop >boolean ; M: method-body stack-effect "multi-method" word-prop method-generic stack-effect ; @@ -209,13 +210,13 @@ M: hook-combination generic-prologue USE: qualified QUALIFIED: syntax -PREDICATE: word generic +PREDICATE: generic < word "multi-combination" word-prop >boolean ; -PREDICATE: word standard-generic +PREDICATE: standard-generic < word "multi-combination" word-prop standard-combination? ; -PREDICATE: word hook-generic +PREDICATE: hook-generic < word "multi-combination" word-prop hook-combination? ; syntax:M: standard-generic definer drop \ GENERIC: f ; @@ -233,7 +234,7 @@ syntax:M: hook-generic synopsis* dup "multi-combination" word-prop hook-combination-var pprint-word stack-effect. ; -PREDICATE: array method-spec +PREDICATE: method-spec < array unclip generic? >r [ class? ] all? r> and ; syntax:M: method-spec where diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor index 7403b7cb05..9d415d8394 100755 --- a/extra/opengl/shaders/shaders.factor +++ b/extra/opengl/shaders/shaders.factor @@ -55,9 +55,9 @@ IN: opengl.shaders : delete-gl-shader ( shader -- ) glDeleteShader ; inline -PREDICATE: integer gl-shader (gl-shader?) ; -PREDICATE: gl-shader vertex-shader (vertex-shader?) ; -PREDICATE: gl-shader fragment-shader (fragment-shader?) ; +PREDICATE: gl-shader < integer (gl-shader?) ; +PREDICATE: vertex-shader < gl-shader (vertex-shader?) ; +PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; ! Programs @@ -126,7 +126,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; MACRO: with-gl-program ( uniforms quot -- ) (make-with-gl-program) ; -PREDICATE: integer gl-program (gl-program?) ; +PREDICATE: gl-program < integer (gl-program?) ; : ( vertex-shader-source fragment-shader-source -- program ) >r check-gl-shader diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index 2d0f5bb5d0..c689f729d1 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -25,7 +25,7 @@ namespaces math math.parser openssl prettyprint sequences tools.test ; [ ] [ ssl-v23 new-ctx ] unit-test -[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test +[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test ! TODO: debug 'Memory protection fault at address 6c' ! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd @@ -33,10 +33,10 @@ namespaces math math.parser openssl prettyprint sequences tools.test ; [ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test ! Enter PEM pass phrase: password -[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path +[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path SSL_FILETYPE_PEM use-private-key ] unit-test -[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f +[ ] [ get-ctx "extra/openssl/test/root.pem" resource-path f verify-load-locations ] unit-test [ ] [ get-ctx 1 set-verify-depth ] unit-test @@ -45,7 +45,7 @@ verify-load-locations ] unit-test ! Load Diffie-Hellman parameters ! ========================================================= -[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test +[ ] [ "extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test [ ] [ get-bio f f f read-pem-dh-params ] unit-test @@ -129,7 +129,7 @@ verify-load-locations ] unit-test ! Dump errors to file ! ========================================================= -[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test +[ ] [ "extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test [ 6 ] [ get-bio "Hello\n" bio-print ] unit-test diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor index 0b77443a50..9ec9f2f4a3 100755 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -5,8 +5,9 @@ sequences words ; IN: singleton : define-singleton ( token -- ) - \ word swap create-class-in - dup [ eq? ] curry define-predicate-class ; + create-class-in + \ word + over [ eq? ] curry define-predicate-class ; : SINGLETON: scan define-singleton ; parsing diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index f731f5d694..cf23e42283 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -155,7 +155,6 @@ IN: tools.deploy.shaker layouts:tag-numbers layouts:type-numbers lexer-factory - lexer-factory listener:listener-hook root-cache vocab-roots diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor index dbb838a5c5..f73276bbe6 100755 --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -9,7 +9,7 @@ SYMBOL: +nullary+ SYMBOL: +listener+ SYMBOL: +description+ -PREDICATE: word listener-command +listener+ word-prop ; +PREDICATE: listener-command < word +listener+ word-prop ; GENERIC: invoke-command ( target command -- ) diff --git a/extra/ui/operations/operations.factor b/extra/ui/operations/operations.factor old mode 100644 new mode 100755 index 45cd7732c2..a9009e386e --- a/extra/ui/operations/operations.factor +++ b/extra/ui/operations/operations.factor @@ -19,7 +19,7 @@ TUPLE: operation predicate command translator hook listener? ; set-operation-hook } operation construct ; -PREDICATE: operation listener-operation +PREDICATE: listener-operation < operation dup operation-command listener-command? swap operation-listener? or ; diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor index bd3fd4ae2a..4dc91a73c2 100755 --- a/extra/unicode/syntax/syntax.factor +++ b/extra/unicode/syntax/syntax.factor @@ -35,7 +35,7 @@ IN: unicode.syntax ] [ ] make ; : define-category ( word categories -- ) - [category] fixnum -rot define-predicate-class ; + [category] integer swap define-predicate-class ; : CATEGORY: CREATE ";" parse-tokens define-category ; parsing diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor old mode 100644 new mode 100755 index ffccb5e0f5..1194ff4df1 --- a/extra/xml-rpc/xml-rpc.factor +++ b/extra/xml-rpc/xml-rpc.factor @@ -17,7 +17,7 @@ M: integer item>xml [ "Integers must fit in 32 bits" throw ] unless number>string "i4" build-tag ; -PREDICATE: object boolean { t f } member? ; +PREDICATE: boolean < object { t f } member? ; M: boolean item>xml "1" "0" ? "boolean" build-tag ; diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor old mode 100644 new mode 100755 index 9d73a46cd9..a7c8bf7b73 --- a/extra/xml/data/data.factor +++ b/extra/xml/data/data.factor @@ -139,5 +139,5 @@ M: xml like : ( name attrs -- tag ) f ; -PREDICATE: tag contained-tag tag-children not ; -PREDICATE: tag open-tag tag-children ; +PREDICATE: contained-tag < tag tag-children not ; +PREDICATE: open-tag < tag tag-children ; diff --git a/vm/data_gc.c b/vm/data_gc.c index 342bbb6af4..0a1fad575a 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -156,10 +156,12 @@ CELL untagged_object_size(CELL pointer) /* Size of the data area of an object pointed to by an untagged pointer */ CELL unaligned_object_size(CELL pointer) { + F_TUPLE *tuple; + F_TUPLE_LAYOUT *layout; + switch(untag_header(get(pointer))) { case ARRAY_TYPE: - case TUPLE_TYPE: case BIGNUM_TYPE: return array_size(array_capacity((F_ARRAY*)pointer)); case BYTE_ARRAY_TYPE: @@ -173,6 +175,10 @@ CELL unaligned_object_size(CELL pointer) float_array_capacity((F_FLOAT_ARRAY*)pointer)); case STRING_TYPE: return string_size(string_capacity((F_STRING*)pointer)); + case TUPLE_TYPE: + tuple = untag_object(pointer); + layout = untag_object(tuple->layout); + return tuple_size(layout); case QUOTATION_TYPE: return sizeof(F_QUOTATION); case WORD_TYPE: @@ -192,6 +198,8 @@ CELL unaligned_object_size(CELL pointer) case CALLSTACK_TYPE: return callstack_size( untag_fixnum_fast(((F_CALLSTACK *)pointer)->length)); + case TUPLE_LAYOUT_TYPE: + return sizeof(F_TUPLE_LAYOUT); default: critical_error("Invalid header",pointer); return -1; /* can't happen */ diff --git a/vm/debug.c b/vm/debug.c index 279d925bd7..7e18738afc 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -57,6 +57,35 @@ void print_array(F_ARRAY* array, CELL nesting) printf("..."); } +void print_tuple(F_TUPLE* tuple, CELL nesting) +{ + F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); + CELL length = to_fixnum(layout->size); + + printf(" "); + print_nested_obj(layout->class,nesting); + + CELL i; + bool trimmed; + + if(length > 10) + { + trimmed = true; + length = 10; + } + else + trimmed = false; + + for(i = 0; i < length; i++) + { + printf(" "); + print_nested_obj(tuple_nth(tuple,i),nesting); + } + + if(trimmed) + printf("..."); +} + void print_nested_obj(CELL obj, F_FIXNUM nesting) { if(nesting <= 0) @@ -83,7 +112,7 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting) break; case TUPLE_TYPE: printf("T{"); - print_array(untag_object(obj),nesting - 1); + print_tuple(untag_object(obj),nesting - 1); printf(" }"); break; case ARRAY_TYPE: diff --git a/vm/image.c b/vm/image.c index d9f8ac2461..28c6c40c1d 100755 --- a/vm/image.c +++ b/vm/image.c @@ -216,25 +216,45 @@ void fixup_callstack_object(F_CALLSTACK *stack) /* Initialize an object in a newly-loaded image */ void relocate_object(CELL relocating) { - do_slots(relocating,data_fixup); - - switch(untag_header(get(relocating))) + /* Tuple relocation is a bit trickier; we have to fix up the + fixup object before we can get the tuple size, so do_slots is + out of the question */ + if(untag_header(get(relocating)) == TUPLE_TYPE) { - case WORD_TYPE: - fixup_word((F_WORD *)relocating); - break; - case QUOTATION_TYPE: - fixup_quotation((F_QUOTATION *)relocating); - break; - case DLL_TYPE: - ffi_dlopen((F_DLL *)relocating); - break; - case ALIEN_TYPE: - fixup_alien((F_ALIEN *)relocating); - break; - case CALLSTACK_TYPE: - fixup_callstack_object((F_CALLSTACK *)relocating); - break; + data_fixup((CELL *)relocating + 1); + + CELL scan = relocating + 2 * CELLS; + CELL size = untagged_object_size(relocating); + CELL end = relocating + size; + + while(scan < end) + { + data_fixup((CELL *)scan); + scan += CELLS; + } + } + else + { + do_slots(relocating,data_fixup); + + switch(untag_header(get(relocating))) + { + case WORD_TYPE: + fixup_word((F_WORD *)relocating); + break; + case QUOTATION_TYPE: + fixup_quotation((F_QUOTATION *)relocating); + break; + case DLL_TYPE: + ffi_dlopen((F_DLL *)relocating); + break; + case ALIEN_TYPE: + fixup_alien((F_ALIEN *)relocating); + break; + case CALLSTACK_TYPE: + fixup_callstack_object((F_CALLSTACK *)relocating); + break; + } } } diff --git a/vm/layouts.h b/vm/layouts.h index 5ed7c83df2..ff938309e7 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -58,8 +58,9 @@ typedef signed long long s64; #define ALIEN_TYPE 16 #define WORD_TYPE 17 #define BYTE_ARRAY_TYPE 18 +#define TUPLE_LAYOUT_TYPE 19 -#define TYPE_COUNT 19 +#define TYPE_COUNT 20 INLINE bool immediate_p(CELL obj) { @@ -224,3 +225,25 @@ typedef struct /* Frame size in bytes */ CELL size; } F_STACK_FRAME; + +typedef struct +{ + CELL header; + /* tagged fixnum */ + CELL hashcode; + /* tagged */ + CELL class; + /* tagged fixnum */ + CELL size; + /* tagged array */ + CELL superclasses; + /* tagged fixnum */ + CELL echelon; +} F_TUPLE_LAYOUT; + +typedef struct +{ + CELL header; + /* tagged layout */ + CELL layout; +} F_TUPLE; diff --git a/vm/primitives.c b/vm/primitives.c index ce26c20f63..203ebb7f6b 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -169,11 +169,10 @@ void *primitives[] = { primitive_wrapper, primitive_clone, primitive_string, - primitive_to_tuple, primitive_array_to_quotation, primitive_quotation_xt, primitive_tuple, - primitive_tuple_to_array, + primitive_tuple_layout, primitive_profiling, primitive_become, primitive_sleep, diff --git a/vm/run.c b/vm/run.c index 2e541a5b6c..d03d999ffd 100755 --- a/vm/run.c +++ b/vm/run.c @@ -320,8 +320,9 @@ DEFINE_PRIMITIVE(class_hash) CELL tag = TAG(obj); if(tag == TUPLE_TYPE) { - F_WORD *class = untag_object(get(SLOT(obj,2))); - drepl(class->hashcode); + 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))); diff --git a/vm/types.c b/vm/types.c index fb61213385..24bb4cb3ca 100755 --- a/vm/types.c +++ b/vm/types.c @@ -379,45 +379,61 @@ DEFINE_PRIMITIVE(resize_float_array) dpush(tag_object(reallot_float_array(array,capacity))); } +/* Tuple layouts */ +DEFINE_PRIMITIVE(tuple_layout) +{ + F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT)); + layout->echelon = dpop(); + layout->superclasses = dpop(); + layout->size = dpop(); + layout->class = dpop(); + layout->hashcode = untag_word(layout->class)->hashcode; + dpush(tag_object(layout)); +} + /* Tuples */ /* push a new tuple on the stack */ +F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) +{ + REGISTER_UNTAGGED(layout); + F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout)); + UNREGISTER_UNTAGGED(layout); + tuple->layout = tag_object(layout); + return tuple; +} + DEFINE_PRIMITIVE(tuple) { - CELL size = unbox_array_size(); - F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); - set_array_nth(array,0,dpop()); - dpush(tag_tuple(array)); + F_TUPLE_LAYOUT *layout = untag_object(dpop()); + F_FIXNUM size = to_fixnum(layout->size); + + F_TUPLE *tuple = allot_tuple(layout); + F_FIXNUM i; + for(i = size - 1; i >= 0; i--) + put(AREF(tuple,i),F); + + dpush(tag_tuple(tuple)); } /* push a new tuple on the stack, filling its slots from the stack */ DEFINE_PRIMITIVE(tuple_boa) { - CELL size = unbox_array_size(); - F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); - set_array_nth(array,0,dpop()); + F_TUPLE_LAYOUT *layout = untag_object(dpop()); + F_FIXNUM size = to_fixnum(layout->size); - CELL i; - for(i = size - 1; i >= 2; i--) - set_array_nth(array,i,dpop()); + REGISTER_UNTAGGED(layout); + F_TUPLE *tuple = allot_tuple(layout); + UNREGISTER_UNTAGGED(layout); - dpush(tag_tuple(array)); -} + /* set delegate slot */ + put(AREF(tuple,0),F); -DEFINE_PRIMITIVE(tuple_to_array) -{ - CELL object = dpeek(); - type_check(TUPLE_TYPE,object); - object = RETAG(clone(object),OBJECT_TYPE); - set_slot(object,0,tag_header(ARRAY_TYPE)); - drepl(object); -} + F_FIXNUM i; + for(i = size - 1; i >= 1; i--) + put(AREF(tuple,i),dpop()); -DEFINE_PRIMITIVE(to_tuple) -{ - CELL object = RETAG(clone(dpeek()),TUPLE_TYPE); - set_slot(object,0,tag_header(TUPLE_TYPE)); - drepl(object); + dpush(tag_tuple(tuple)); } /* Strings */ diff --git a/vm/types.h b/vm/types.h index 62b2e06dd0..03ac84d5a5 100755 --- a/vm/types.h +++ b/vm/types.h @@ -96,11 +96,34 @@ DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) DEFINE_UNTAG(F_WORD,WORD_TYPE,word) -INLINE CELL tag_tuple(F_ARRAY *tuple) +INLINE CELL tag_tuple(F_TUPLE *tuple) { return RETAG(tuple,TUPLE_TYPE); } +INLINE F_TUPLE *untag_tuple(CELL object) +{ + type_check(TUPLE_TYPE,object); + return untag_object(object); +} + +INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout) +{ + CELL size = untag_fixnum_fast(layout->size); + return sizeof(F_TUPLE) + size * CELLS; +} + +INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot) +{ + return get(AREF(tuple,slot)); +} + +INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value) +{ + put(AREF(tuple,slot),value); + write_barrier((CELL)tuple); +} + /* Prototypes */ DLLEXPORT void box_boolean(bool value); DLLEXPORT bool to_boolean(CELL value); @@ -116,12 +139,11 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); DECLARE_PRIMITIVE(array); DECLARE_PRIMITIVE(tuple); DECLARE_PRIMITIVE(tuple_boa); +DECLARE_PRIMITIVE(tuple_layout); DECLARE_PRIMITIVE(byte_array); DECLARE_PRIMITIVE(bit_array); DECLARE_PRIMITIVE(float_array); DECLARE_PRIMITIVE(clone); -DECLARE_PRIMITIVE(tuple_to_array); -DECLARE_PRIMITIVE(to_tuple); F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill); DECLARE_PRIMITIVE(resize_array);