From 690621ffb653807c68457b5caf83933a38fb207e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 18:23:19 -0500 Subject: [PATCH] Change PREDICATE: syntax --- core/alien/alien.factor | 4 +- core/arrays/arrays.factor | 2 +- core/classes/algebra/algebra-docs.factor | 6 +- core/classes/algebra/algebra-tests.factor | 2 +- core/classes/classes-tests.factor | 2 +- core/classes/classes.factor | 8 +-- core/classes/mixin/mixin.factor | 2 +- core/classes/predicate/predicate-docs.factor | 2 +- core/classes/predicate/predicate.factor | 8 +-- core/classes/union/union.factor | 2 +- core/cpu/architecture/architecture.factor | 6 +- core/cpu/arm/assembler/assembler.factor | 2 +- core/cpu/x86/32/32.factor | 2 +- core/cpu/x86/64/64.factor | 2 +- core/cpu/x86/assembler/assembler.factor | 24 +++++--- core/debugger/debugger.factor | 2 +- core/generic/generic-tests.factor | 2 +- core/generic/generic.factor | 7 ++- core/generic/math/math.factor | 4 +- core/generic/standard/standard.factor | 6 +- core/inference/dataflow/dataflow.factor | 6 +- core/parser/parser-tests.factor | 2 +- core/parser/parser.factor | 2 +- core/prettyprint/prettyprint-tests.factor | 6 ++ core/prettyprint/prettyprint.factor | 3 +- core/sequences/sequences.factor | 2 +- core/slots/deprecated/deprecated.factor | 4 +- core/syntax/syntax-docs.factor | 10 ++- core/syntax/syntax.factor | 5 +- core/tuples/tuples-docs.factor | 10 +-- core/tuples/tuples-tests.factor | 65 ++++++++++++++++++-- core/tuples/tuples.factor | 8 ++- core/words/words.factor | 6 +- extra/delegate/delegate.factor | 2 +- extra/help/markup/markup.factor | 2 +- extra/help/topics/topics.factor | 2 +- extra/inverse/inverse.factor | 6 +- extra/io/nonblocking/nonblocking.factor | 4 +- extra/locals/locals.factor | 14 ++--- extra/macros/macros.factor | 2 +- extra/memoize/memoize.factor | 2 +- extra/multi-methods/multi-methods.factor | 11 ++-- extra/opengl/shaders/shaders.factor | 8 +-- extra/singleton/singleton.factor | 5 +- extra/ui/commands/commands.factor | 2 +- extra/ui/operations/operations.factor | 2 +- extra/unicode/syntax/syntax.factor | 2 +- extra/xml-rpc/xml-rpc.factor | 2 +- extra/xml/data/data.factor | 4 +- 49 files changed, 184 insertions(+), 110 deletions(-) mode change 100644 => 100755 core/arrays/arrays.factor mode change 100644 => 100755 extra/ui/operations/operations.factor mode change 100644 => 100755 extra/xml-rpc/xml-rpc.factor mode change 100644 => 100755 extra/xml/data/data.factor 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/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 b6082ad334..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 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/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/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/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/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 0a00c742a0..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 ; 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..26c6076769 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> ; 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/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 17b3b86269..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,8 +148,9 @@ IN: bootstrap.syntax ] define-syntax "PREDICATE:" [ - scan-word CREATE-CLASS + scan "<" assert= + scan-word parse-definition define-predicate-class ] define-syntax diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 427c7fbf60..6e0f319c9a 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -165,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" } "." } ; @@ -190,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." } @@ -214,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" } ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 702557e257..e7ad44a264 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -2,7 +2,8 @@ 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 accessors ; +strings compiler.units accessors classes.algebra calendar +prettyprint io.streams.string ; IN: tuples.tests TUPLE: rect x y w h ; @@ -83,7 +84,7 @@ C: predicate-test [ t ] [ predicate-test? ] unit-test -PREDICATE: tuple silly-pred +PREDICATE: silly-pred < tuple class \ rect = ; GENERIC: area @@ -243,6 +244,58 @@ C: erg's-reshape-problem "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval ] [ [ no-tuple-class? ] is? ] must-fail-with +! Inheritance +TUPLE: computer cpu ram ; + +[ "IN: tuples.tests TUPLE: computer cpu ram ;\n" ] [ + [ \ computer see ] with-string-writer +] 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 + +[ "IN: tuples.tests TUPLE: laptop < computer battery ;\n" ] [ + [ \ laptop see ] with-string-writer +] 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 + +[ "IN: tuples.tests TUPLE: server < computer rackmount ;\n" ] [ + [ \ server see ] with-string-writer +] unit-test + +[ + "IN: tuples.tests TUPLE: bad-superclass < word ;" eval +] must-fail + ! Hardcore unit tests USE: threads @@ -250,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 @@ -268,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 8318c0ede1..83f398242a 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -110,8 +110,11 @@ M: tuple-class tuple-layout "layout" word-prop ; dup define-tuple-layout define-tuple-predicate ; +: change-superclass "not supported" throw ; + : redefine-tuple-class ( class superclass slots -- ) - nip + >r 2dup swap superclass eq? + [ drop ] [ dupd change-superclass ] if r> 2dup forget-slots 2dup reshape-tuples over changed-word @@ -119,8 +122,7 @@ M: tuple-class tuple-layout "layout" word-prop ; prepare-tuple-class ; : define-new-tuple-class ( class superclass slots -- ) - nip - over f tuple tuple-class define-class + >r dupd f swap tuple-class define-class r> prepare-tuple-class ; PRIVATE> 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/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/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/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/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 ;