From b36e06d0d6a70e225d459cbfc0872e025c4fd7b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 28 Jun 2008 02:36:20 -0500 Subject: [PATCH] Builtinn types now use new slot accessors; tuple slot type declaration work in progress --- core/alien/alien-docs.factor | 2 +- core/alien/alien.factor | 12 +- core/alien/c-types/c-types.factor | 5 +- .../remote-control/remote-control.factor | 6 +- core/alien/strings/strings.factor | 2 +- core/alien/structs/structs-docs.factor | 8 +- core/alien/structs/structs.factor | 28 +-- core/bootstrap/compiler/compiler.factor | 19 +- core/bootstrap/image/image.factor | 34 +-- core/bootstrap/primitives.factor | 228 +++++------------- core/bootstrap/stage2.factor | 4 +- core/bootstrap/syntax.factor | 3 + core/byte-vectors/byte-vectors.factor | 4 + core/classes/algebra/algebra.factor | 2 +- core/classes/classes.factor | 8 +- core/classes/tuple/parser/parser-tests.factor | 59 +++++ core/classes/tuple/parser/parser.factor | 24 +- core/classes/tuple/tuple-docs.factor | 33 ++- core/classes/tuple/tuple-tests.factor | 8 +- core/classes/tuple/tuple.factor | 15 +- core/combinators/combinators-tests.factor | 6 +- core/combinators/combinators.factor | 4 +- core/compiler/tests/intrinsics.factor | 2 +- core/compiler/tests/redefine1.factor | 28 +-- core/compiler/tests/redefine3.factor | 4 +- core/compiler/tests/simple.factor | 2 +- core/compiler/tests/templates.factor | 4 +- core/compiler/units/units.factor | 6 +- core/continuations/continuations-tests.factor | 2 +- core/cpu/ppc/intrinsics/intrinsics.factor | 4 +- core/cpu/x86/64/64.factor | 2 +- core/cpu/x86/intrinsics/intrinsics.factor | 6 +- core/effects/effects.factor | 4 +- core/generator/fixup/fixup.factor | 4 +- core/generator/generator.factor | 4 +- core/generic/generic-tests.factor | 8 +- core/generic/generic.factor | 8 +- .../standard/engines/tuple/tuple.factor | 4 +- core/generic/standard/standard-tests.factor | 2 +- core/growable/growable-docs.factor | 26 +- core/growable/growable.factor | 27 +-- core/hashtables/hashtables-docs.factor | 2 +- core/hashtables/hashtables.factor | 43 ++-- core/inference/backend/backend.factor | 8 +- core/inference/class/class-tests.factor | 2 +- core/inference/inference-tests.factor | 2 +- core/inference/known-words/known-words.factor | 4 +- .../transforms/transforms-tests.factor | 6 +- core/inspector/inspector.factor | 8 +- core/io/streams/string/string.factor | 10 +- core/io/styles/styles-docs.factor | 2 +- core/kernel/kernel.factor | 8 + core/lexer/lexer.factor | 2 +- core/math/bitfields/bitfields-tests.factor | 2 +- core/math/math-docs.factor | 4 +- core/math/math.factor | 6 + core/mirrors/mirrors.factor | 6 +- core/optimizer/def-use/def-use-tests.factor | 4 +- core/optimizer/inlining/inlining.factor | 8 +- core/optimizer/known-words/known-words.factor | 4 +- core/optimizer/math/math.factor | 2 +- core/optimizer/math/partial/partial.factor | 12 +- core/optimizer/optimizer-tests.factor | 14 +- .../specializers/specializers.factor | 8 +- core/parser/parser.factor | 2 +- core/prettyprint/backend/backend.factor | 16 +- core/prettyprint/prettyprint.factor | 6 +- core/prettyprint/sections/sections.factor | 2 +- core/quotations/quotations.factor | 27 +-- core/sbufs/sbufs.factor | 19 +- core/slots/deprecated/deprecated.factor | 34 +-- core/slots/slots-docs.factor | 12 +- core/slots/slots-tests.factor | 18 ++ core/slots/slots.factor | 100 ++++++-- core/sorting/sorting.factor | 6 +- core/strings/strings.factor | 7 +- core/syntax/syntax-docs.factor | 42 +++- core/syntax/syntax.factor | 10 +- core/vectors/vectors.factor | 4 + core/words/words-docs.factor | 36 +-- core/words/words-tests.factor | 4 +- core/words/words.factor | 41 ++-- extra/alias/alias.factor | 2 +- extra/bit-vectors/bit-vectors.factor | 12 +- extra/cpu/8080/emulator/emulator.factor | 2 +- extra/db/queries/queries.factor | 2 +- extra/delegate/delegate.factor | 4 +- extra/descriptive/descriptive.factor | 2 +- extra/fjsc/fjsc.factor | 6 +- extra/float-vectors/float-vectors.factor | 12 +- extra/furnace/furnace.factor | 4 +- extra/furnace/utilities/utilities.factor | 2 +- extra/help/help.factor | 12 +- extra/help/lint/lint.factor | 17 +- extra/help/markup/markup.factor | 12 +- .../html/templates/chloe/syntax/syntax.factor | 4 +- extra/inverse/inverse.factor | 2 +- .../unix/sockets/secure/secure-tests.factor | 2 +- extra/io/unix/unix.factor | 4 +- extra/koszul/koszul.factor | 2 +- extra/locals/locals.factor | 8 +- extra/logging/logging.factor | 2 +- extra/logging/parser/parser-docs.factor | 2 +- extra/logging/parser/parser.factor | 2 +- extra/logging/server/server.factor | 6 +- extra/math/complex/complex.factor | 9 +- extra/math/ratios/ratios-docs.factor | 4 +- extra/math/ratios/ratios.factor | 7 +- extra/multi-methods/multi-methods.factor | 2 +- extra/odbc/odbc.factor | 4 +- extra/optimizer/debugger/debugger.factor | 6 +- extra/optimizer/report/report.factor | 2 +- extra/present/present.factor | 2 +- extra/reports/noise/noise.factor | 2 +- extra/reports/optimizer/optimizer.factor | 2 +- extra/semantic-db/semantic-db.factor | 8 +- extra/serialize/serialize.factor | 10 +- extra/tools/annotations/annotations.factor | 10 +- extra/tools/crossref/crossref.factor | 4 +- extra/tools/deploy/shaker/shaker.factor | 6 +- extra/tools/profiler/profiler.factor | 8 +- extra/tools/vocabs/browser/browser.factor | 10 +- extra/tools/walker/walker.factor | 2 +- extra/ui/commands/commands.factor | 8 +- extra/ui/gestures/gestures.factor | 4 +- extra/ui/tools/listener/listener.factor | 6 +- extra/ui/tools/operations/operations.factor | 2 +- extra/ui/tools/search/search.factor | 6 +- extra/ui/windows/windows.factor | 2 +- extra/unicode/script/script.factor | 4 +- extra/unix/kqueue/kqueue.factor | 2 +- extra/usa-cities/usa-cities.factor | 2 +- extra/values/values.factor | 6 +- extra/vars/vars.factor | 4 +- extra/windows/messages/messages.factor | 2 +- extra/xml/utilities/utilities.factor | 2 +- extra/xmode/code2html/code2html.factor | 2 +- extra/xmode/tokens/tokens.factor | 2 +- 138 files changed, 783 insertions(+), 706 deletions(-) create mode 100644 core/classes/tuple/parser/parser-tests.factor create mode 100644 core/slots/slots-tests.factor diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 0caf0e9a9f..331aa819bb 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -10,7 +10,7 @@ HELP: alien HELP: dll { $class-description "The class of native library handles. See " { $link "syntax-aliens" } " for syntax and " { $link "dll.private" } " for general information." } ; -HELP: expired? ( c-ptr -- ? ) +HELP: expired? { $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } } { $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired." $nl diff --git a/core/alien/alien.factor b/core/alien/alien.factor index cc37b85103..9db6b54837 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,13 +1,12 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math namespaces sequences system +USING: accessors assocs kernel math namespaces sequences system kernel.private bit-arrays byte-arrays float-arrays arrays ; IN: alien ! Some predicate classes used by the compiler for optimization ! purposes -PREDICATE: simple-alien < alien - underlying-alien not ; +PREDICATE: simple-alien < alien underlying>> not ; UNION: simple-c-ptr simple-alien POSTPONE: f byte-array bit-array float-array ; @@ -17,12 +16,15 @@ alien POSTPONE: f byte-array bit-array float-array ; DEFER: pinned-c-ptr? -PREDICATE: pinned-alien < alien - underlying-alien pinned-c-ptr? ; +PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ; UNION: pinned-c-ptr pinned-alien POSTPONE: f ; +GENERIC: expired? ( c-ptr -- ? ) + +M: alien expired? expired?>> ; + M: f expired? drop t ; : ( address -- alien ) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 87fa553dc3..2fac81e1c6 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -242,11 +242,10 @@ M: long-long-type box-return ( type -- ) } 2cleave ; : expand-constants ( c-type -- c-type' ) - #! We use word-def call instead of execute to get around + #! We use def>> call instead of execute to get around #! staging violations dup array? [ - unclip >r [ dup word? [ word-def call ] when ] map - r> prefix + unclip >r [ dup word? [ def>> call ] when ] map r> prefix ] when ; : malloc-file-contents ( path -- alien len ) diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor index 027663a645..344c8a2c5a 100755 --- a/core/alien/remote-control/remote-control.factor +++ b/core/alien/remote-control/remote-control.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings parser threads words -kernel.private kernel io.encodings.utf8 ; +USING: accessors alien alien.c-types alien.strings parser +threads words kernel.private kernel io.encodings.utf8 ; IN: alien.remote-control : eval-callback ( -- callback ) @@ -15,7 +15,7 @@ IN: alien.remote-control "void" { "long" } "cdecl" [ sleep ] alien-callback ; : ?callback ( word -- alien ) - dup compiled? [ execute ] [ drop f ] if ; inline + dup compiled>> [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) \ eval-callback ?callback 16 setenv diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 827d478d06..70bbe773ee 100755 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -100,7 +100,7 @@ M: utf16n drop utf16n ; os windows? [ utf16n ] [ utf8 ] if alien>string ; : dll-path ( dll -- string ) - (dll-path) alien>native-string ; + path>> alien>native-string ; : string>symbol ( str -- alien ) [ os wince? [ utf16n ] [ utf8 ] if string>alien ] diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index baf0b40707..81e9ab97f7 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -7,7 +7,7 @@ kernel words slots assocs namespaces ; : ($spec-reader-values) ( slot-spec class -- element ) dup ?word-name swap 2array over slot-spec-name - rot slot-spec-type 2array 2array + rot slot-spec-class 2array 2array [ { $instance } swap suffix ] assoc-map ; : $spec-reader-values ( slot-spec class -- ) @@ -22,6 +22,9 @@ kernel words slots assocs namespaces ; " instance." , ] { } make $description ; +: slot-of-reader ( reader specs -- spec/f ) + [ slot-spec-reader eq? ] with find nip ; + : $spec-reader ( reader slot-specs class -- ) >r slot-of-reader r> over [ @@ -49,6 +52,9 @@ M: word slot-specs "slots" word-prop ; " instance." , ] { } make $description ; +: slot-of-writer ( writer specs -- spec/f ) + [ slot-spec-writer eq? ] with find nip ; + : $spec-writer ( writer slot-specs class -- ) >r slot-of-writer r> over [ diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index bc5fa5a3f1..8671b77c9e 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables kernel kernel.private math -namespaces parser sequences strings words libc slots +USING: accessors arrays generic hashtables kernel kernel.private +math namespaces parser sequences strings words libc slots slots.deprecated alien.c-types cpu.architecture ; IN: alien.structs @@ -10,9 +10,9 @@ IN: alien.structs : struct-offsets ( specs -- size ) 0 [ - [ slot-spec-type align-offset ] keep + [ class>> align-offset ] keep [ set-slot-spec-offset ] 2keep - slot-spec-type heap-size + + class>> heap-size + ] reduce ; : define-struct-slot-word ( spec word quot -- ) @@ -23,7 +23,7 @@ IN: alien.structs [ ] [ slot-spec-reader ] [ - slot-spec-type + class>> [ c-getter ] [ c-type c-type-boxer-quot ] bi append ] tri define-struct-slot-word ; @@ -32,7 +32,7 @@ IN: alien.structs [ set-writer-props ] keep [ ] [ slot-spec-writer ] - [ slot-spec-type c-setter ] tri + [ class>> c-setter ] tri define-struct-slot-word ; : define-field ( type spec -- ) @@ -77,13 +77,13 @@ M: struct-type stack-size -rot define-c-type ; : make-field ( struct-name vocab type field-name -- spec ) - [ - -rot expand-constants , - over , - 3dup reader-word , - writer-word , - ] { } make - first4 0 -rot ; + + 0 >>offset + swap >>name + swap expand-constants >>class + 3dup name>> swap reader-word >>reader + 3dup name>> swap writer-word >>writer + 2nip ; : define-struct-early ( name vocab fields -- fields ) -rot [ rot first2 make-field ] 2curry map ; @@ -94,7 +94,7 @@ M: struct-type stack-size : define-struct ( name vocab fields -- ) pick >r [ struct-offsets ] keep - [ [ slot-spec-type ] map compute-struct-align ] keep + [ [ class>> ] map compute-struct-align ] keep [ (define-struct) ] keep r> [ swap define-field ] curry each ; diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 5480bac4f5..99f9593216 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler cpu.architecture vocabs.loader system sequences -namespaces parser kernel kernel.private classes classes.private -arrays hashtables vectors classes.tuple sbufs inference.dataflow -hashtables.private sequences.private math classes.tuple.private -growable namespaces.private assocs words generator command-line -vocabs io prettyprint libc compiler.units math.order ; +USING: accessors compiler cpu.architecture vocabs.loader system +sequences namespaces parser kernel kernel.private classes +classes.private arrays hashtables vectors classes.tuple sbufs +inference.dataflow hashtables.private sequences.private math +classes.tuple.private growable namespaces.private assocs words +generator command-line vocabs io prettyprint libc compiler.units +math.order ; IN: bootstrap.compiler ! Don't bring this in when deploying, since it will store a @@ -14,12 +15,12 @@ IN: bootstrap.compiler "alien.remote-control" require ] unless -"cpu." cpu word-name append require +"cpu." cpu name>> append require enable-compiler : compile-uncompiled ( words -- ) - [ compiled? not ] filter compile ; + [ compiled>> not ] filter compile ; nl "Compiling..." write flush @@ -40,8 +41,6 @@ nl wrap probe - underlying - namestack* bitand bitor bitxor bitnot diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 64b2cdb550..e070fe1fd6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -12,8 +12,8 @@ io.encodings.binary math.order accessors ; IN: bootstrap.image : my-arch ( -- arch ) - cpu word-name - dup "ppc" = [ >r os word-name "-" r> 3append ] when ; + cpu name>> + dup "ppc" = [ >r os name>> "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; @@ -260,10 +260,10 @@ M: f ' [ { [ hashcode , ] - [ word-name , ] - [ word-vocabulary , ] - [ word-def , ] - [ word-props , ] + [ name>> , ] + [ vocabulary>> , ] + [ def>> , ] + [ props>> , ] } cleave f , 0 , ! count @@ -277,7 +277,7 @@ M: f ' ] keep put-object ; : word-error ( word msg -- * ) - [ % dup word-vocabulary % " " % word-name % ] "" make throw ; + [ % dup vocabulary>> % " " % name>> % ] "" make throw ; : transfer-word ( word -- word ) [ target-word ] keep or ; @@ -294,7 +294,7 @@ M: word ' ; ! Wrappers M: wrapper ' - wrapped ' wrapper type-number object tag-number + wrapped>> ' wrapper type-number object tag-number [ emit ] emit-object ; ! Strings @@ -345,7 +345,7 @@ M: float-array ' float-array emit-dummy-array ; tuple type-number dup [ emit-seq ] emit-object ; : emit-tuple ( tuple -- pointer ) - dup class word-name "tombstone" = + dup class name>> "tombstone" = [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ; M: tuple ' emit-tuple ; @@ -354,11 +354,11 @@ M: tuple-layout ' [ [ { - [ layout-hashcode , ] - [ layout-class , ] - [ layout-size , ] - [ layout-superclasses , ] - [ layout-echelon , ] + [ hashcode>> , ] + [ class>> , ] + [ size>> , ] + [ superclasses>> , ] + [ echelon>> , ] } cleave ] { } make [ ' ] map \ tuple-layout type-number @@ -368,7 +368,7 @@ M: tuple-layout ' M: tombstone ' delegate "((tombstone))" "((empty))" ? "hashtables.private" lookup - word-def first [ emit-tuple ] cache-object ; + def>> first [ emit-tuple ] cache-object ; ! Arrays M: array ' @@ -379,10 +379,10 @@ M: array ' M: quotation ' [ - quotation-array ' + array>> ' quotation type-number object tag-number [ emit ! array - f ' emit ! compiled? + f ' emit ! compiled>> 0 emit ! xt 0 emit ! code ] emit-object diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index e4e0db8609..44f18603bf 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -5,7 +5,7 @@ hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes classes.builtin classes.tuple classes.tuple.private kernel.private vocabs vocabs.loader source-files definitions -slots.deprecated classes.union classes.intersection +slots classes.union classes.intersection compiler.units bootstrap.image.private io.files accessors combinators ; IN: bootstrap.primitives @@ -133,9 +133,12 @@ bootstrapping? on [ f f f builtin-class define-class ] tri ; -: define-builtin-slots ( symbol slotspec -- ) - [ drop ] [ 1 simple-slots ] 2bi - [ "slots" set-word-prop ] [ define-slots ] 2bi ; +: prepare-slots ( slots -- slots' ) + [ [ dup array? [ first2 create ] when ] map ] map ; + +: define-builtin-slots ( class slots -- ) + prepare-slots 1 make-slots + [ "slots" set-word-prop ] [ define-accessors ] 2bi ; : define-builtin ( symbol slotspec -- ) >r [ define-builtin-predicate ] keep @@ -189,16 +192,14 @@ bi "ratio" "math" create { { - { "integer" "math" } "numerator" - { "numerator" "math" } - f + { "integer" "math" } + read-only: t } { - { "integer" "math" } "denominator" - { "denominator" "math" } - f + { "integer" "math" } + read-only: t } } define-builtin @@ -207,16 +208,14 @@ bi "complex" "math" create { { + "real" { "real" "math" } - "real-part" - { "real-part" "math" } - f + read-only: t } { + "imaginary" { "real" "math" } - "imaginary-part" - { "imaginary-part" "math" } - f + read-only: t } } define-builtin @@ -226,104 +225,87 @@ bi "wrapper" "kernel" create { { - { "object" "kernel" } "wrapped" - { "wrapped" "kernel" } - f + { "object" "kernel" } + read-only: t } } define-builtin "string" "strings" create { { - { "array-capacity" "sequences.private" } "length" - { "length" "sequences" } - f + { "array-capacity" "sequences.private" } + read-only: t } { - { "object" "kernel" } "aux" - { "string-aux" "strings.private" } - { "set-string-aux" "strings.private" } + { "object" "kernel" } } } define-builtin "quotation" "quotations" create { { - { "object" "kernel" } "array" - { "quotation-array" "quotations.private" } - f + { "object" "kernel" } + read-only: t } { + "compiled" { "object" "kernel" } - "compiled?" - { "quotation-compiled?" "quotations" } - f + read-only: t } } define-builtin "dll" "alien" create { { - { "byte-array" "byte-arrays" } - "path" - { "(dll-path)" "alien" } - f + "path" + { "byte-array" "byte-arrays" } + read-only: t } } define-builtin "alien" "alien" create { { + "underlying" { "c-ptr" "alien" } - "alien" - { "underlying-alien" "alien" } - f + read-only: t } { - { "object" "kernel" } "expired?" - { "expired?" "alien" } - f + { "object" "kernel" } + read-only: t } } define-builtin "word" "words" create { - f { - { "object" "kernel" } - "name" - { "word-name" "words" } - { "set-word-name" "words" } + "hashcode" + { "fixnum" "math" } } { + "name" { "object" "kernel" } + } + { "vocabulary" - { "word-vocabulary" "words" } - { "set-word-vocabulary" "words" } + { "object" "kernel" } } { - { "quotation" "quotations" } "def" - { "word-def" "words" } - { "set-word-def" "words.private" } + { "quotation" "quotations" } } { - { "object" "kernel" } "props" - { "word-props" "words" } - { "set-word-props" "words" } + { "object" "kernel" } } { + "compiled" { "object" "kernel" } - "compiled?" - { "compiled?" "words" } - f + read-only: t } { - { "fixnum" "math" } "counter" - { "profile-counter" "tools.profiler.private" } - { "set-profile-counter" "tools.profiler.private" } + { "fixnum" "math" } } } define-builtin @@ -337,34 +319,29 @@ define-builtin "tuple-layout" "classes.tuple.private" create { { - { "fixnum" "math" } "hashcode" - { "layout-hashcode" "classes.tuple.private" } - f + { "fixnum" "math" } + read-only: t } { - { "word" "words" } "class" - { "layout-class" "classes.tuple.private" } - f + { "word" "words" } + read-only: t } { - { "fixnum" "math" } "size" - { "layout-size" "classes.tuple.private" } - f + { "fixnum" "math" } + read-only: t } { - { "array" "arrays" } "superclasses" - { "layout-superclasses" "classes.tuple.private" } - f + { "array" "arrays" } + read-only: t } { - { "fixnum" "math" } "echelon" - { "layout-echelon" "classes.tuple.private" } - f + { "fixnum" "math" } + read-only: t } } define-builtin @@ -375,15 +352,13 @@ define-builtin [ { { - { "object" "kernel" } "delegate" - { "delegate" "kernel" } - { "set-delegate" "kernel" } + { "object" "kernel" } } - } + } prepare-slots [ drop ] [ generate-tuple-slots ] 2bi [ "slots" set-word-prop ] - [ define-slots ] + [ define-accessors ] 2bi ] } cleave @@ -405,90 +380,19 @@ tuple 2array >tuple 1quotation define-inline ! Some tuple classes -"hashtable" "hashtables" create -tuple -{ - { - { "array-capacity" "sequences.private" } - "count" - { "hash-count" "hashtables.private" } - { "set-hash-count" "hashtables.private" } - } { - { "array-capacity" "sequences.private" } - "deleted" - { "hash-deleted" "hashtables.private" } - { "set-hash-deleted" "hashtables.private" } - } { - { "array" "arrays" } - "array" - { "hash-array" "hashtables.private" } - { "set-hash-array" "hashtables.private" } - } -} define-tuple-class - -"sbuf" "sbufs" create -tuple -{ - { - { "string" "strings" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "length" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - -"vector" "vectors" create -tuple -{ - { - { "array" "arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - -"byte-vector" "byte-vectors" create -tuple -{ - { - { "byte-array" "byte-arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } -} define-tuple-class - "curry" "kernel" create tuple { { - { "object" "kernel" } "obj" - { "curry-obj" "kernel" } - f - } { { "object" "kernel" } + read-only: t + } { "quot" - { "curry-quot" "kernel" } - f + { "object" "kernel" } + read-only: t } -} define-tuple-class +} prepare-slots define-tuple-class "curry" "kernel" lookup [ f "inline" set-word-prop ] @@ -500,17 +404,15 @@ tuple tuple { { - { "object" "kernel" } "first" - { "compose-first" "kernel" } - f - } { { "object" "kernel" } + read-only: t + } { "second" - { "compose-second" "kernel" } - f + { "object" "kernel" } + read-only: t } -} define-tuple-class +} prepare-slots define-tuple-class "compose" "kernel" lookup [ f "inline" set-word-prop ] diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 5ee263469e..69f594b9fa 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: init command-line namespaces words debugger io +USING: accessors init command-line namespaces words debugger io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings @@ -36,7 +36,7 @@ SYMBOL: bootstrap-time "Bootstrap completed in " write number>string write " minutes and " write number>string write " seconds." print - [ compiled? ] count-words " compiled words" print + [ compiled>> ] count-words " compiled words" print [ symbol? ] count-words " symbol words" print [ ] count-words " words total" print diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index f3d7707878..1155eef6cf 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -45,6 +45,7 @@ IN: bootstrap.syntax "SINGLETON:" "SYMBOL:" "TUPLE:" + "SLOT:" "T{" "UNION:" "INTERSECTION:" @@ -68,6 +69,8 @@ IN: bootstrap.syntax "<<" ">>" "call-next-method" + "initial:" + "read-only:" } [ "syntax" create drop ] each "t" "syntax" lookup define-symbol diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index e80b797a8d..5560454b3a 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -4,6 +4,10 @@ USING: arrays kernel kernel.private math sequences sequences.private growable byte-arrays ; IN: byte-vectors +TUPLE: byte-vector +{ "underlying" byte-array } +{ "length" array-capacity } ; + vector ( byte-array length -- byte-vector ) diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index a9c1520fc6..b7e4bebe15 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -214,7 +214,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; [ "Topological sort failed" throw ] unless* ; : sort-classes ( seq -- newseq ) - [ [ word-name ] compare ] sort >vector + [ [ name>> ] compare ] sort >vector [ dup empty? not ] [ dup largest-class >r over delete-nth r> ] [ ] unfold nip ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 35ff475abf..2f4c56f8a8 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions assocs kernel kernel.private +USING: accessors arrays definitions assocs kernel kernel.private slots.private namespaces sequences strings words vectors math quotations combinators sorting effects graphs vocabs sets ; IN: classes @@ -38,7 +38,7 @@ PREDICATE: tuple-class < class : classes ( -- seq ) implementors-map get keys ; : predicate-word ( word -- predicate ) - [ word-name "?" append ] keep word-vocabulary create ; + [ name>> "?" append ] [ vocabulary>> ] bi create ; PREDICATE: predicate < word "predicating" word-prop >boolean ; @@ -123,8 +123,8 @@ M: sequence implementors [ implementors ] gather ; dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless dup reset-class dup deferred? [ dup define-symbol ] when - dup word-props - r> assoc-union over set-word-props + dup props>> + r> assoc-union >>props dup predicate-word [ 1quotation "predicate" set-word-prop ] [ swap "predicating" set-word-prop ] diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor new file mode 100644 index 0000000000..580907d761 --- /dev/null +++ b/core/classes/tuple/parser/parser-tests.factor @@ -0,0 +1,59 @@ +IN: classes.tuple.parser.tests +USING: accessors classes.tuple.parser lexer words classes +sequences math kernel slots tools.test parser compiler.units ; + +TUPLE: test-1 ; + +[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test + +TUPLE: test-2 < test-1 ; + +[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test +[ test-1 ] [ test-2 superclass ] unit-test + +TUPLE: test-3 a ; + +[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test + +[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test + +TUPLE: test-4 < test-3 b ; + +[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test + +TUPLE: test-5 { "a" integer } ; + +[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test + +TUPLE: test-6 < test-5 { "b" integer } ; + +[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test + +[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test + +TUPLE: test-7 { "b" integer initial: 3 } ; + +[ 3 ] [ "b" test-7 "slots" word-prop slot-named initial>> ] unit-test + +TUPLE: test-8 { "b" integer read-only: t } ; + +[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test + +[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ] +[ error>> invalid-slot-name? ] +must-fail-with + +[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ] +[ error>> invalid-slot-name? ] +must-fail-with + +[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ] +[ error>> unexpected-eof? ] +must-fail-with + +[ ] [ + [ + { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 } + [ dup class? [ forget-class ] [ drop ] if ] each + ] with-compilation-unit +] unit-test diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index ab3be109e1..a4bea6fed2 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sets namespaces sequences inspector parser -lexer combinators words classes.parser classes.tuple ; +USING: accessors kernel sets namespaces sequences inspector parser +lexer combinators words classes.parser classes.tuple arrays ; IN: classes.tuple.parser : shadowed-slots ( superclass slots -- shadowed ) @@ -13,7 +13,7 @@ IN: classes.tuple.parser "Definition of slot ``" % % "'' in class ``" % - word-name % + name>> % "'' shadows a superclass slot" % ] "" make note. ] with each ; @@ -24,27 +24,27 @@ M: invalid-slot-name summary drop "Invalid slot name" ; -: (parse-tuple-slots) ( -- ) +: parse-slot-name ( string/f -- ? ) #! This isn't meant to enforce any kind of policy, just #! to check for mistakes of this form: #! #! TUPLE: blahblah foo bing #! #! : ... - scan { + { { [ dup not ] [ unexpected-eof ] } - { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] } - { [ dup ";" = ] [ drop ] } - [ , (parse-tuple-slots) ] + { [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] } + { [ dup ";" = ] [ drop f ] } + [ dup "{" = [ drop \ } parse-until >array ] when , t ] } cond ; -: parse-tuple-slots ( -- seq ) - [ (parse-tuple-slots) ] { } make ; +: parse-tuple-slots ( -- ) + scan parse-slot-name [ parse-tuple-slots ] when ; : parse-tuple-definition ( -- class superclass slots ) CREATE-CLASS scan { { ";" [ tuple f ] } - { "<" [ scan-word parse-tuple-slots ] } - [ >r tuple parse-tuple-slots r> prefix ] + { "<" [ scan-word [ parse-tuple-slots ] { } make ] } + [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] } case 3dup check-slot-shadowing ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 9f8ce83240..f23c2d20ed 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -1,6 +1,7 @@ USING: generic help.markup help.syntax kernel classes.tuple.private classes slots quotations words arrays -generic.standard sequences definitions compiler.units ; +generic.standard sequences definitions compiler.units +growable vectors sbufs ; IN: classes.tuple ARTICLE: "parametrized-constructors" "Parameterized constructors" @@ -242,6 +243,34 @@ $nl } "Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ; +ARTICLE: "protocol-slots" "Protocol slots" +"A " { $emphasis "protocol slot" } " is one which is assumed to exist by the implementation of a class, without being defined on the class itself. The burden is on subclasses (or mixin instances) to provide this slot." +$nl +"Protocol slots are defined using a parsing word:" +{ $subsection POSTPONE: SLOT: } +"Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass." +$nl +"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots:" +{ $snippet "SLOT: length" "SLOT: underlying" } +"An alternate approach would be to define " { $link growable } " as a tuple class with these two slots, and have other classes subclass it as required. However, this rules out subclasses defining these slots with custom type declarations." +$nl +"For example, compare the definitions of the " { $link sbuf } " class," +{ $code + "TUPLE: sbuf" + "{ \"underlying\" string }" + "{ \"length\" array-capacity } ;" + "" + "INSTANCE: sbuf growable" +} +"with that of the " { $link vector } " class:" +{ $code + "TUPLE: vector" + "{ \"underlying\" array }" + "{ \"length\" array-capacity } ;" + "" + "INSTANCE: vector growable" +} ; + ARTICLE: "tuples" "Tuples" "Tuples are user-defined classes composed of named slots." { $subsection "tuple-examples" } @@ -255,6 +284,8 @@ $nl { $subsection "tuple-constructors" } "Expressing relationships through the object system:" { $subsection "tuple-subclassing" } +"Protocol slots:" +{ $subsection "protocol-slots" } "Introspection:" { $subsection "tuple-introspection" } "Tuple classes can be redefined; this updates existing instances:" diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index c93bd11ffe..a5282ce7d3 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -88,13 +88,13 @@ C: empty [ t length ] [ object>> t eq? ] must-fail-with [ "" ] -[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test +[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval word name>> ] unit-test TUPLE: size-test a b c d ; [ t ] [ T{ size-test } tuple-size - size-test tuple-layout layout-size = + size-test tuple-layout size>> = ] unit-test GENERIC: @@ -253,8 +253,8 @@ test-laptop-slot-values [ laptop ] [ "laptop" get 1 slot - dup layout-echelon swap - layout-superclasses nth + dup echelon>> swap + superclasses>> nth ] unit-test [ "TUPLE: laptop < computer battery ;" ] [ diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index df59f34ff4..5db4a43bf0 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -25,7 +25,7 @@ ERROR: not-a-tuple-class class ; check-tuple-class "layout" word-prop ; : tuple-size ( tuple -- size ) - 1 slot layout-size ; inline + 1 slot size>> ; inline : prepare-tuple>array ( tuple -- n tuple layout ) check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ; @@ -38,7 +38,7 @@ PRIVATE> : tuple>array ( tuple -- array ) prepare-tuple>array >r copy-tuple-slots r> - layout-class prefix ; + class>> prefix ; : tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; @@ -78,10 +78,10 @@ ERROR: bad-superclass class ; #! 5 slot == layout-echelon [ [ 1 slot dup 5 slot ] % - dup tuple-layout layout-echelon , + dup tuple-layout echelon>> , [ fixnum>= ] % [ - dup tuple-layout layout-echelon , + dup tuple-layout echelon>> , [ swap 4 slot array-nth ] % literalize , [ eq? ] % @@ -106,7 +106,7 @@ ERROR: bad-superclass class ; [ slot-names length ] map sum ; : generate-tuple-slots ( class slots -- slot-specs ) - over superclass-size 2 + simple-slots ; + over superclass-size 2 + make-slots deprecated-slots ; : define-tuple-slots ( class -- ) dup dup "slot-names" word-prop generate-tuple-slots @@ -212,13 +212,14 @@ M: tuple-class define-tuple-class M: tuple-class reset-class [ - dup "slot-names" word-prop [ + dup "slots" word-prop [ + name>> [ reader-word method forget ] [ writer-word method forget ] 2bi ] with each ] [ [ call-next-method ] - [ { "layout" "slots" } reset-props ] + [ { "layout" "slots" "slot-names" } reset-props ] bi ] bi ; diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index b612669b71..8ce3923019 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -140,7 +140,7 @@ IN: combinators.tests [ "two" ] [ 2 case-test-1 ] unit-test ! Interpreted -[ "two" ] [ 2 \ case-test-1 word-def call ] unit-test +[ "two" ] [ 2 \ case-test-1 def>> call ] unit-test [ "x" case-test-1 ] must-fail @@ -158,7 +158,7 @@ IN: combinators.tests [ 25 ] [ 5 case-test-2 ] unit-test ! Interpreted -[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test +[ 25 ] [ 5 \ case-test-2 def>> call ] unit-test : case-test-3 ( obj -- obj' ) { @@ -288,7 +288,7 @@ IN: combinators.tests ] unit-test ! Interpreted -[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test +[ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test [ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test [ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index f6873429fe..57b9ac8fc6 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays sequences sequences.private math.private +USING: accessors arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting words sets math.order ; IN: combinators @@ -45,7 +45,7 @@ ERROR: no-case ; dupd first dup word? [ execute ] [ - dup wrapper? [ wrapped ] when + dup wrapper? [ wrapped>> ] when ] if = ] [ quotation? ] if ] find nip ; diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 0e5c96eca0..3582ee71a1 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -377,7 +377,7 @@ cell 8 = [ [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test -: xword-def ( word -- def ) word-def [ { fixnum } declare ] prepend ; +: xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ; [ -100 ] [ -100 [ { byte-array } declare *char ] compile-call ] unit-test [ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test diff --git a/core/compiler/tests/redefine1.factor b/core/compiler/tests/redefine1.factor index b7abacc6e4..38929d1282 100644 --- a/core/compiler/tests/redefine1.factor +++ b/core/compiler/tests/redefine1.factor @@ -23,13 +23,13 @@ M: integer method-redefine-test 3 + ; : hey ( -- ) ; : there ( -- ) hey ; -[ t ] [ \ hey compiled? ] unit-test -[ t ] [ \ there compiled? ] unit-test +[ t ] [ \ hey compiled>> ] unit-test +[ t ] [ \ there compiled>> ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test -[ f ] [ \ hey compiled? ] unit-test -[ f ] [ \ there compiled? ] unit-test +[ f ] [ \ hey compiled>> ] unit-test +[ f ] [ \ there compiled>> ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test -[ t ] [ \ there compiled? ] unit-test +[ t ] [ \ there compiled>> ] unit-test ! Just changing the stack effect didn't mark a word for recompilation DEFER: change-effect @@ -44,24 +44,24 @@ DEFER: change-effect : bad ( -- ) good ; : ugly ( -- ) bad ; -[ t ] [ \ good compiled? ] unit-test -[ t ] [ \ bad compiled? ] unit-test -[ t ] [ \ ugly compiled? ] unit-test +[ t ] [ \ good compiled>> ] unit-test +[ t ] [ \ bad compiled>> ] unit-test +[ t ] [ \ ugly compiled>> ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test -[ f ] [ \ good compiled? ] unit-test -[ f ] [ \ bad compiled? ] unit-test -[ f ] [ \ ugly compiled? ] unit-test +[ f ] [ \ good compiled>> ] unit-test +[ f ] [ \ bad compiled>> ] unit-test +[ f ] [ \ ugly compiled>> ] unit-test [ t ] [ \ good compiled-usage assoc-empty? ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test -[ t ] [ \ good compiled? ] unit-test -[ t ] [ \ bad compiled? ] unit-test -[ t ] [ \ ugly compiled? ] unit-test +[ t ] [ \ good compiled>> ] unit-test +[ t ] [ \ bad compiled>> ] unit-test +[ t ] [ \ ugly compiled>> ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test diff --git a/core/compiler/tests/redefine3.factor b/core/compiler/tests/redefine3.factor index 2b27b64b61..9f839399a8 100644 --- a/core/compiler/tests/redefine3.factor +++ b/core/compiler/tests/redefine3.factor @@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ; : sheeple-test ( -- string ) { } sheeple ; [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test compiled? ] unit-test +[ t ] [ \ sheeple-test compiled>> ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test @@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ; [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test compiled? ] unit-test +[ t ] [ \ sheeple-test compiled>> ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 68c85d6d97..f3e29a6284 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ; 10 [ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ t ] [ - "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval + "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval ] unit-test ] times diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 65ef68deb8..760a0036bc 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -245,13 +245,13 @@ TUPLE: my-tuple ; [ dup float+ ] } cleave ; -[ t ] [ \ float-spill-bug compiled? ] unit-test +[ t ] [ \ float-spill-bug compiled>> ] unit-test ! Regression : dispatch-alignment-regression ( -- c ) { tuple vector } 3 slot { word } declare dup 1 slot 0 fixnum-bitand { [ ] } dispatch ; -[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test +[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test [ vector ] [ dispatch-alignment-regression ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index b0c4948956..d141bf68e3 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations assocs namespaces sequences words -vocabs definitions hashtables init sets ; +USING: accessors kernel continuations assocs namespaces +sequences words vocabs definitions hashtables init sets ; IN: compiler.units SYMBOL: old-definitions @@ -54,7 +54,7 @@ GENERIC: definitions-changed ( assoc obj -- ) : changed-vocabs ( assoc -- vocabs ) [ drop word? ] assoc-filter - [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ; + [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ; : updated-definitions ( -- assoc ) H{ } clone diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 27e1f02b91..7ff71cdd2d 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -66,7 +66,7 @@ IN: continuations.tests [ 1 3 2 ] [ bar ] unit-test -[ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test +[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 1b28f7262e..61a27ec88f 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -438,13 +438,13 @@ IN: cpu.ppc.intrinsics } define-intrinsic \ [ - tuple "layout" get layout-size 2 + cells %allot + tuple "layout" get size>> 2 + cells %allot ! Store layout "layout" get 12 load-indirect 12 11 cell STW ! Zero out the rest of the tuple f v>operand 12 LI - "layout" get layout-size [ 12 11 rot 2 + cells STW ] each + "layout" get size>> [ 12 11 rot 2 + cells STW ] each ! Store tagged ptr in reg "tuple" get tuple %store-tagged ] H{ diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index ebaa6056ff..8a9a0c89dd 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -178,7 +178,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >> : struct-types&offset ( struct-type -- pairs ) struct-type-fields [ - dup slot-spec-type swap slot-spec-offset 2array + [ type>> ] [ offset>> ] bi 2array ] map ; : split-struct ( pairs -- seq ) diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 0ee8a0a1d9..8d537f66c4 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.accessors arrays cpu.x86.assembler +USING: accessors alien alien.accessors arrays cpu.x86.assembler cpu.x86.allot cpu.x86.architecture cpu.architecture kernel kernel.private math math.private namespaces quotations sequences words generic byte-arrays hashtables hashtables.private @@ -290,12 +290,12 @@ IN: cpu.x86.intrinsics } define-intrinsic \ [ - tuple "layout" get layout-size 2 + cells [ + tuple "layout" get size>> 2 + cells [ ! Store layout "layout" get "scratch" get load-literal 1 object@ "scratch" operand MOV ! Zero out the rest of the tuple - "layout" get layout-size [ + "layout" get size>> [ 2 + object@ f v>operand MOV ] each ! Store tagged ptr in reg diff --git a/core/effects/effects.factor b/core/effects/effects.factor index d7923ad595..6aee6fbcb2 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -24,7 +24,7 @@ TUPLE: effect in out terminated? ; GENERIC: (stack-picture) ( obj -- str ) M: string (stack-picture) ; -M: word (stack-picture) word-name ; +M: word (stack-picture) name>> ; M: integer (stack-picture) drop "object" ; : stack-picture ( seq -- string ) @@ -46,7 +46,7 @@ M: symbol stack-effect drop (( -- symbol )) ; M: word stack-effect { "declared-effect" "inferred-effect" } - swap word-props [ at ] curry map [ ] find nip ; + swap props>> [ at ] curry map [ ] find nip ; M: effect clone [ in>> clone ] [ out>> clone ] bi ; diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index a0961984ed..058822bf2f 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -88,7 +88,7 @@ TUPLE: rel-fixup arg class type ; : rel-fixup ( arg class type -- ) \ rel-fixup boa , ; : push-4 ( value vector -- ) - [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri + [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri swap set-alien-unsigned-4 ; M: rel-fixup fixup* @@ -120,7 +120,7 @@ SYMBOL: literal-table >r add-literal r> rt-xt rel-fixup ; : rel-primitive ( word class -- ) - >r word-def first r> rt-primitive rel-fixup ; + >r def>> first r> rt-primitive rel-fixup ; : rel-literal ( literal class -- ) >r add-literal r> rt-literal rel-fixup ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 241858c95b..d369c047d9 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs classes combinators cpu.architecture +USING: accessors arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel kernel.private layouts math namespaces optimizer @@ -20,7 +20,7 @@ SYMBOL: compiled } cond ; : maybe-compile ( word -- ) - dup compiled? [ drop ] [ queue-compile ] if ; + dup compiled>> [ drop ] [ queue-compile ] if ; SYMBOL: compiling-word diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 9d968a3a98..5e76f584e3 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -144,7 +144,7 @@ M: integer generic-forget-test-1 / ; [ t ] [ \ / usage [ word? ] filter - [ word-name "generic-forget-test-1/integer" = ] contains? + [ name>> "generic-forget-test-1/integer" = ] contains? ] unit-test [ ] [ @@ -153,7 +153,7 @@ M: integer generic-forget-test-1 / ; [ f ] [ \ / usage [ word? ] filter - [ word-name "generic-forget-test-1/integer" = ] contains? + [ name>> "generic-forget-test-1/integer" = ] contains? ] unit-test GENERIC: generic-forget-test-2 ( a b -- c ) @@ -162,7 +162,7 @@ M: sequence generic-forget-test-2 = ; [ t ] [ \ = usage [ word? ] filter - [ word-name "generic-forget-test-2/sequence" = ] contains? + [ name>> "generic-forget-test-2/sequence" = ] contains? ] unit-test [ ] [ @@ -171,7 +171,7 @@ M: sequence generic-forget-test-2 = ; [ f ] [ \ = usage [ word? ] filter - [ word-name "generic-forget-test-2/sequence" = ] contains? + [ name>> "generic-forget-test-2/sequence" = ] contains? ] unit-test GENERIC: generic-forget-test-3 ( a -- b ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index ca6949366a..47cc4c7a54 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: words kernel sequences namespaces assocs hashtables -definitions kernel.private classes classes.private +USING: accessors words kernel sequences namespaces assocs +hashtables definitions kernel.private classes classes.private classes.algebra quotations arrays vocabs effects combinators sets ; IN: generic @@ -72,7 +72,7 @@ TUPLE: check-method class generic ; 3tri ; inline : method-word-name ( class word -- string ) - word-name "/" rot word-name 3append ; + [ name>> ] bi@ "=>" swap 3append ; PREDICATE: method-body < word "method-generic" word-prop >boolean ; @@ -93,7 +93,7 @@ M: method-body crossref? check-method [ method-word-props ] 2keep method-word-name f - [ set-word-props ] keep ; + swap >>props ; : with-implementors ( class generic quot -- ) [ swap implementors-map get at ] dip call ; inline diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 2654490d88..cf2d50b6e2 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -18,7 +18,7 @@ C: trivial-tuple-dispatch-engine TUPLE: tuple-dispatch-engine echelons ; : push-echelon ( class method assoc -- ) - >r swap dup "layout" word-prop layout-echelon r> + >r swap dup "layout" word-prop echelon>> r> [ ?set-at ] change-at ; : echelon-sort ( assoc -- assoc' ) @@ -54,7 +54,7 @@ M: trivial-tuple-dispatch-engine engine>quot ] [ ] make ; : engine-word-name ( -- string ) - generic get word-name "/tuple-dispatch-engine" append ; + generic get name>> "/tuple-dispatch-engine" append ; PREDICATE: engine-word < word "tuple-dispatch-generic" word-prop generic? ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 93956fec00..9cee497d6d 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -287,7 +287,7 @@ M: sbuf no-stack-effect-decl ; [ ] [ \ no-stack-effect-decl see ] unit-test -[ ] [ \ no-stack-effect-decl word-def . ] unit-test +[ ] [ \ no-stack-effect-decl def>> . ] unit-test ! Cross-referencing with generic words TUPLE: xref-tuple-1 ; diff --git a/core/growable/growable-docs.factor b/core/growable/growable-docs.factor index 9de3c8ab24..9f950aa36c 100755 --- a/core/growable/growable-docs.factor +++ b/core/growable/growable-docs.factor @@ -7,31 +7,17 @@ ARTICLE: "growable" "Resizable sequence implementation" $nl "There is a resizable sequence mixin:" { $subsection growable } -"This mixin implements the sequence protocol in terms of a growable protocol:" -{ $subsection underlying } -{ $subsection set-underlying } -{ $subsection set-fill } +"This mixin implements the sequence protocol by assuming the object has two specific slots:" +{ $list + { { $snippet "length" } " - the fill pointer (number of occupied elements in the underlying storage)" } + { { $snippet "underlying" } " - the underlying storage" } +} "The underlying sequence must implement a generic word:" { $subsection resize } -{ $link "vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ; +{ $link "vectors" } ", " { $link "byte-vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ; ABOUT: "growable" -HELP: set-fill -{ $values { "n" "a new fill pointer" } { "seq" growable } } -{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." } -{ $side-effects "seq" } -{ $warning "This word is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; - -HELP: underlying -{ $values { "seq" growable } { "underlying" "the underlying sequence" } } -{ $contract "Outputs the underlying storage of a resizable sequence." } ; - -HELP: set-underlying -{ $values { "underlying" sequence } { "seq" growable } } -{ $contract "Modifies the underlying storage of a resizable sequence." } -{ $warning "This word is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; - HELP: capacity { $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } } { $description "Outputs the number of elements the sequence can hold without growing." } ; diff --git a/core/growable/growable.factor b/core/growable/growable.factor index d660610e3f..559a3f192a 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -1,24 +1,24 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. ! Some low-level code used by vectors and string buffers. -USING: kernel kernel.private math math.private +USING: accessors kernel kernel.private math math.private sequences sequences.private ; IN: growable MIXIN: growable -GENERIC: underlying ( seq -- underlying ) -GENERIC: set-underlying ( underlying seq -- ) -GENERIC: set-fill ( n seq -- ) -M: growable nth-unsafe underlying nth-unsafe ; +SLOT: length +SLOT: underlying -M: growable set-nth-unsafe underlying set-nth-unsafe ; +M: growable length length>> ; +M: growable nth-unsafe underlying>> nth-unsafe ; +M: growable set-nth-unsafe underlying>> set-nth-unsafe ; -: capacity ( seq -- n ) underlying length ; inline +: capacity ( seq -- n ) underlying>> length ; inline : expand ( len seq -- ) - [ underlying resize ] keep set-underlying ; inline + [ resize ] change-underlying drop ; inline : contract ( len seq -- ) [ length ] keep @@ -35,7 +35,7 @@ M: growable set-length ( n seq -- ) ] [ 2dup capacity > [ 2dup expand ] when ] if - >r >fixnum r> set-fill ; + swap >fixnum >>length drop ; : new-size ( old -- new ) 1+ 3 * ; inline @@ -44,20 +44,19 @@ M: growable set-length ( n seq -- ) 2dup length >= [ 2dup capacity >= [ over new-size over expand ] when >r >fixnum r> - 2dup >r 1 fixnum+fast r> set-fill + 2dup swap 1 fixnum+fast >>length drop ] [ >r >fixnum r> ] if ; inline M: growable set-nth ensure set-nth-unsafe ; -M: growable clone ( seq -- newseq ) - (clone) dup underlying clone over set-underlying ; +M: growable clone (clone) [ clone ] change-underlying ; M: growable lengthen ( n seq -- ) 2dup length > [ 2dup capacity > [ over new-size over expand ] when - 2dup >r >fixnum r> set-fill + 2dup swap >fixnum >>length drop ] when 2drop ; INSTANCE: growable sequence diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index e3b21e629e..3cd9ee23af 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -8,7 +8,7 @@ ARTICLE: "hashtables.private" "Hashtable implementation details" $nl "There are two special objects: the " { $link ((tombstone)) } " marker and the " { $link ((empty)) } " marker. Neither of these markers can be used as hashtable keys." $nl -"The " { $link hash-count } " slot is the number of entries including deleted entries, and " { $link hash-deleted } " is the number of deleted entries." +"The " { $snippet "count" } " slot is the number of entries including deleted entries, and " { $snippet "deleted" } " is the number of deleted entries." { $subsection } { $subsection set-nth-pair } "If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:" diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index a1dba07fb0..e991be5ab3 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -1,9 +1,14 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private slots.private math assocs -math.private sequences sequences.private vectors grouping ; +USING: accessors arrays kernel kernel.private slots.private math +assocs math.private sequences sequences.private vectors grouping ; IN: hashtables +TUPLE: hashtable +{ "count" array-capacity } +{ "deleted" array-capacity } +{ "array" array } ; + > 2dup hash@ (key@) ; inline : ( n -- array ) 1+ next-power-of-2 4 * ((empty)) ; inline : init-hash ( hash -- ) - 0 over set-hash-count 0 swap set-hash-deleted ; + 0 >>count 0 >>deleted drop ; inline : reset-hash ( n hash -- ) - swap over set-hash-array init-hash ; + swap >>array init-hash ; : (new-key@) ( key keys i -- keys n empty? ) 3dup swap array-nth dup ((empty)) eq? [ @@ -46,17 +51,17 @@ IN: hashtables ] if ; inline : new-key@ ( key hash -- array n empty? ) - hash-array 2dup hash@ (new-key@) ; inline + array>> 2dup hash@ (new-key@) ; inline : set-nth-pair ( value key seq n -- ) 2 fixnum+fast [ set-slot ] 2keep 1 fixnum+fast set-slot ; inline : hash-count+ ( hash -- ) - dup hash-count 1+ swap set-hash-count ; inline + [ 1+ ] change-count drop ; inline : hash-deleted+ ( hash -- ) - dup hash-deleted 1+ swap set-hash-deleted ; inline + [ 1+ ] change-deleted drop ; inline : (set-hash) ( value key hash -- new? ) 2dup new-key@ @@ -67,11 +72,11 @@ IN: hashtables swap [ swapd (set-hash) drop ] curry assoc-each ; : hash-large? ( hash -- ? ) - [ hash-count 3 fixnum*fast ] - [ hash-array array-capacity ] bi > ; + [ count>> 3 fixnum*fast ] + [ array>> array-capacity ] bi > ; : hash-stale? ( hash -- ? ) - [ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ; + [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; : grow-hash ( hash -- ) [ dup >alist swap assoc-size 1+ ] keep @@ -98,7 +103,7 @@ M: hashtable at* ( key hash -- value ? ) key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ; M: hashtable clear-assoc ( hash -- ) - dup init-hash hash-array [ drop ((empty)) ] change-each ; + [ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ; M: hashtable delete-at ( key hash -- ) tuck key@ [ @@ -109,14 +114,12 @@ M: hashtable delete-at ( key hash -- ) ] if ; M: hashtable assoc-size ( hash -- n ) - dup hash-count swap hash-deleted - ; + [ count>> ] [ deleted>> ] bi - ; : rehash ( hash -- ) - dup >alist - over hash-array length ((empty)) pick set-hash-array - 0 pick set-hash-count - 0 pick set-hash-deleted - (rehash) ; + dup >alist >r + dup clear-assoc + r> (rehash) ; M: hashtable set-at ( value key hash -- ) dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ; @@ -125,10 +128,10 @@ M: hashtable set-at ( value key hash -- ) 2 [ set-at ] keep ; M: hashtable >alist - hash-array 2 [ first tombstone? not ] filter ; + array>> 2 [ first tombstone? not ] filter ; M: hashtable clone - (clone) dup hash-array clone over set-hash-array ; + (clone) [ clone ] change-array ; M: hashtable equal? over hashtable? [ diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 59fbd289db..b4a533597c 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -111,7 +111,7 @@ GENERIC: apply-object ( obj -- ) M: object apply-object apply-literal ; M: wrapper apply-object - wrapped dup +called+ depends-on apply-literal ; + wrapped>> dup +called+ depends-on apply-literal ; : terminate ( -- ) terminated? on #terminate node, ; @@ -400,7 +400,7 @@ TUPLE: missing-effect word ; { [ dup inline? ] [ drop f ] } { [ dup deferred? ] [ drop f ] } { [ dup crossref? not ] [ drop f ] } - [ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ] + [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ] } cond ; : ?missing-effect ( word -- ) @@ -429,7 +429,7 @@ TUPLE: missing-effect word ; [ init-inference dependencies off - dup word-def over dup infer-quot-recursive + dup def>> over dup infer-quot-recursive end-infer finish-word current-effect @@ -492,7 +492,7 @@ M: #return collect-label-info* : inline-block ( word -- #label data ) [ copy-inference nest-node - [ word-def ] [ ] bi + [ def>> ] [ ] bi [ infer-quot-recursive ] 2keep #label unnest-node dup collect-label-info diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 770763bfb6..39b33d4b63 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -159,7 +159,7 @@ DEFER: blah [ dup V{ } eq? [ foo ] when ] dup second dup push define ] with-compilation-unit - \ blah word-def dataflow optimize drop + \ blah def>> dataflow optimize drop ] unit-test GENERIC: detect-fx ( n -- n ) diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index c9c3f1de6b..12efcbd509 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -271,7 +271,7 @@ DEFER: #1 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; -[ \ #4 word-def infer ] must-fail +[ \ #4 def>> infer ] must-fail [ [ #1 ] infer ] must-fail ! Similar diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 3282cbb5e2..3a54ccf975 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.accessors arrays bit-arrays byte-arrays +USING: accessors alien alien.accessors arrays bit-arrays byte-arrays classes sequences.private continuations.private effects float-arrays generic hashtables hashtables.private inference.state inference.backend inference.dataflow io @@ -137,7 +137,7 @@ M: object infer-call ! Variadic tuple constructor \ [ \ - peek-d value-literal layout-size { tuple } + peek-d value-literal size>> { tuple } make-call-node ] "infer" set-word-prop diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 7f5f8035fb..a102063c93 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -31,19 +31,19 @@ C: color [ 1 2 3 ] [ 1 2 3 cleave-test ] unit-test -[ 1 2 3 ] [ 1 2 3 \ cleave-test word-def call ] unit-test +[ 1 2 3 ] [ 1 2 3 \ cleave-test def>> call ] unit-test : 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ; [ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test -[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test +[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test def>> call ] unit-test : spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ; [ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test -[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test +[ 16 -3 1/6 ] [ 4 3 6 \ spread-test def>> call ] unit-test [ fixnum instance? ] must-infer diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor index d32f1c90cf..07c189cea0 100755 --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables io kernel assocs math +USING: accessors arrays generic hashtables io kernel assocs math namespaces prettyprint sequences strings io.styles vectors words quotations mirrors splitting math.parser classes vocabs refs sets sorting ; @@ -9,7 +9,7 @@ IN: inspector GENERIC: summary ( object -- string ) : object-summary ( object -- string ) - class word-name " instance" append ; + class name>> " instance" append ; M: object summary object-summary ; @@ -24,7 +24,7 @@ M: word summary synopsis ; M: sequence summary [ - dup class word-name % + dup class name>> % " with " % length # " elements" % @@ -32,7 +32,7 @@ M: sequence summary M: assoc summary [ - dup class word-name % + dup class name>> % " with " % assoc-size # " entries" % diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index d2b092abe8..607076b809 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel math namespaces sequences sbufs strings -generic splitting growable continuations destructors -io.streams.plain io.encodings math.order ; +USING: accessors io kernel math namespaces sequences sbufs +strings generic splitting continuations destructors +io.streams.plain io.encodings math.order growable ; IN: io.streams.string M: growable dispose drop ; @@ -21,7 +21,7 @@ M: growable stream-flush drop ; M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ; : harden-as ( seq growble-exemplar -- newseq ) - underlying like ; + underlying>> like ; : growable-read-until ( growable n -- str ) >fixnum dupd tail-slice swap harden-as dup reverse-here ; diff --git a/core/io/styles/styles-docs.factor b/core/io/styles/styles-docs.factor index 5481560f94..43d93c86e7 100644 --- a/core/io/styles/styles-docs.factor +++ b/core/io/styles/styles-docs.factor @@ -94,7 +94,7 @@ HELP: font-style { $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." } { $examples "This example outputs text in all three styles:" - { $code "{ plain bold italic bold-italic }\n[ [ word-name ] keep font-style associate format nl ] each" } + { $code "{ plain bold italic bold-italic }\n[ [ name>> ] keep font-style associate format nl ] each" } } ; HELP: presented diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 1a7d1de47c..aa335aed90 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -197,8 +197,16 @@ M: callstack clone (clone) ; PRIVATE> ! Deprecated +GENERIC: delegate ( obj -- delegate ) + +M: tuple delegate 2 slot ; + M: object delegate drop f ; +GENERIC: set-delegate ( delegate tuple -- ) + +M: tuple set-delegate 2 set-slot ; + GENERIC# get-slots 1 ( tuple slots -- ... ) GENERIC# set-slots 1 ( ... tuple slots -- ) diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 3d65fb95ca..f791cc7391 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -71,7 +71,7 @@ ERROR: unexpected want got ; GENERIC: expected>string ( obj -- str ) M: f expected>string drop "end of input" ; -M: word expected>string word-name ; +M: word expected>string name>> ; M: string expected>string ; M: unexpected error. diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor index 70533ac33f..c1b38011fe 100755 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -14,4 +14,4 @@ IN: math.bitfields.tests [ 3 ] [ foo ] unit-test [ 3 ] [ { a b } flags ] unit-test -[ t ] [ \ foo compiled? ] unit-test +[ t ] [ \ foo compiled>> ] unit-test diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index b15f09e49d..f75a63eefc 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -302,11 +302,11 @@ HELP: fp-nan? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; -HELP: real-part ( z -- x ) +HELP: real-part { $values { "z" number } { "x" real } } { $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } ; -HELP: imaginary-part ( z -- y ) +HELP: imaginary-part { $values { "z" number } { "y" real } } { $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ; diff --git a/core/math/math.factor b/core/math/math.factor index 1dfbf1fc3e..859d0f6f29 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -8,6 +8,12 @@ GENERIC: >bignum ( x -- n ) foldable GENERIC: >integer ( x -- n ) foldable GENERIC: >float ( x -- y ) foldable +GENERIC: numerator ( a/b -- a ) +GENERIC: denominator ( a/b -- b ) + +GENERIC: real-part ( z -- x ) +GENERIC: imaginary-part ( z -- y ) + MATH: number= ( x y -- ? ) foldable M: object number= 2drop f ; diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 607ba1542f..b96d6bf8b5 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -26,10 +26,10 @@ M: mirror at* M: mirror set-at ( val key mirror -- ) [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [ - dup writer>> [ - nip offset>> set-slot - ] [ + dup read-only>> [ drop immutable-slot + ] [ + nip offset>> set-slot ] if ] [ drop no-such-slot diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index f49ab7fcba..87f95afded 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -91,7 +91,7 @@ namespaces assocs kernel sequences math tools.test words sets ; { [ swapd * -rot p2 +@ ] [ 2swap [ swapd * -rot p2 +@ ] 2keep ] - } \ regression-1 word-def kill-set [ member? ] curry map + } \ regression-1 def>> kill-set [ member? ] curry map ] unit-test : regression-2 ( x y -- x.y ) @@ -121,6 +121,6 @@ namespaces assocs kernel sequences math tools.test words sets ; ] with assoc-each ] } - \ regression-2 word-def kill-set + \ regression-2 def>> kill-set [ member? ] curry map ] unit-test diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 9e8f805acf..9438f9c4aa 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic assocs inference inference.class +USING: accessors arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables combinators classes classes.algebra generic.math @@ -37,7 +37,7 @@ DEFER: (flat-length) ! not inline { [ dup inline? not ] [ drop 1 ] } ! inline - [ dup dup set word-def (flat-length) ] + [ dup dup set def>> (flat-length) ] } cond ; : (flat-length) ( seq -- n ) @@ -51,7 +51,7 @@ DEFER: (flat-length) ] map sum ; : flat-length ( seq -- n ) - [ word-def (flat-length) ] with-scope ; + [ def>> (flat-length) ] with-scope ; ! Single dispatch method inlining optimization : node-class# ( node n -- class ) @@ -201,7 +201,7 @@ DEFER: (flat-length) : splice-word-def ( #call word -- node ) dup +inlined+ depends-on - dup word-def swap 1array splice-quot ; + dup def>> swap 1array splice-quot ; : optimistic-inline ( #call -- node ) dup node-param over node-history memq? [ diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index d69a2f94bc..0aadd05e8c 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: optimizer.known-words -USING: alien arrays generic hashtables inference.dataflow +USING: accessors alien arrays generic hashtables inference.dataflow inference.class kernel assocs math math.order math.private kernel.private sequences words parser vectors strings sbufs io namespaces assocs quotations sequences.private io.binary @@ -14,7 +14,7 @@ sequences.private combinators byte-arrays byte-vectors ; { } [ [ dup node-in-d peek node-literal - dup tuple-layout? [ layout-class ] [ drop tuple ] if + dup tuple-layout? [ class>> ] [ drop tuple ] if 1array f ] "output-classes" set-word-prop ] each diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 72e64d5b95..b7a3ff28e7 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -256,7 +256,7 @@ optimizer.math.partial generic.standard system accessors ; alien-signed-8 alien-unsigned-8 } [ - dup word-name { + dup name>> { { [ "alien-signed-" ?head ] [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ] diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor index 30a726e022..4f9bfaef12 100644 --- a/core/optimizer/math/partial/partial.factor +++ b/core/optimizer/math/partial/partial.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private math math.private words +USING: accessors kernel kernel.private math math.private words sequences parser namespaces assocs quotations arrays generic generic.math hashtables effects ; IN: optimizer.math.partial @@ -40,16 +40,16 @@ PREDICATE: math-partial < word << : integer-op-combinator ( triple -- word ) [ - [ second word-name % "-" % ] - [ third word-name % "-op" % ] + [ second name>> % "-" % ] + [ third name>> % "-op" % ] bi ] "" make in get lookup ; : integer-op-word ( triple fix-word big-word -- word ) [ drop - word-name "fast" tail? >r - [ "-" % ] [ word-name % ] interleave + name>> "fast" tail? >r + [ "-" % ] [ name>> % ] interleave r> [ "-fast" % ] when ] "" make in get create ; @@ -86,7 +86,7 @@ PREDICATE: math-partial < word { fixnum bignum float } [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc [ nip ] assoc-filter - [ word-def peek ] assoc-map % ; + [ def>> peek ] assoc-map % ; SYMBOL: math-ops diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 7032e58b3f..8b759ef883 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -17,7 +17,7 @@ IN: optimizer.tests GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; -[ t ] [ \ xyz compiled? ] unit-test +[ t ] [ \ xyz compiled>> ] unit-test ! Test predicate inlining : pred-test-1 @@ -102,7 +102,7 @@ TUPLE: pred-test ; ! regression GENERIC: void-generic ( obj -- * ) : breakage ( -- * ) "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test +[ t ] [ \ breakage compiled>> ] unit-test [ breakage ] must-fail ! regression @@ -133,7 +133,7 @@ GENERIC: void-generic ( obj -- * ) ! compiling with a non-literal class failed : -regression ( class -- tuple ) ; -[ t ] [ \ -regression compiled? ] unit-test +[ t ] [ \ -regression compiled>> ] unit-test GENERIC: foozul ( a -- b ) M: reversed foozul ; @@ -247,7 +247,7 @@ TUPLE: silly-tuple a b ; : node-successor-f-bug ( x -- * ) [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; -[ t ] [ \ node-successor-f-bug compiled? ] unit-test +[ t ] [ \ node-successor-f-bug compiled>> ] unit-test [ ] [ [ new ] dataflow optimize drop ] unit-test @@ -271,7 +271,7 @@ TUPLE: silly-tuple a b ; ] if ] if ; -[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test +[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test @@ -309,7 +309,7 @@ M: integer generic-inline-test ; ! Inlining all of the above should only take two passes [ { t f } ] [ - \ generic-inline-test-1 word-def dataflow + \ generic-inline-test-1 def>> dataflow [ optimize-1 , optimize-1 , drop ] { } make ] unit-test @@ -322,7 +322,7 @@ HINTS: recursive-inline-hang array ; : recursive-inline-hang-1 ( -- a ) { } recursive-inline-hang ; -[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test +[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test DEFER: recursive-inline-hang-3 diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index c3702e9805..90ae7fc6f9 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables kernel kernel.private math -namespaces sequences vectors words strings layouts combinators -sequences.private classes generic.standard +USING: accessors arrays generic hashtables kernel kernel.private +math namespaces sequences vectors words strings layouts +combinators sequences.private classes generic.standard generic.standard.engines assocs ; IN: optimizer.specializers @@ -51,7 +51,7 @@ IN: optimizer.specializers ] [ drop f ] if ; : specialized-def ( word -- quot ) - dup word-def swap { + dup def>> swap { { [ dup standard-method? ] [ specialize-method ] } { [ dup "specializer" word-prop ] diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 601245c463..5ea19ab880 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -81,7 +81,7 @@ M: no-word-error summary dup no-word-error boa swap words-named [ forward-reference? not ] filter word-restarts throw-restarts - dup word-vocabulary (use+) ; + dup vocabulary>> (use+) ; : check-forward ( str word -- word/f ) dup forward-reference? [ diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 3df408cb10..83e40d147f 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays byte-vectors bit-arrays generic +USING: accessors arrays byte-arrays byte-vectors bit-arrays 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 @@ -37,7 +37,7 @@ M: effect pprint* effect>string "(" swap ")" 3append text ; ] keep ; : word-name* ( word -- str ) - word-name "( no name )" or ; + name>> "( no name )" or ; : pprint-word ( word -- ) dup record-vocab @@ -117,7 +117,7 @@ M: pathname pprint* : check-recursion ( obj quot -- ) nesting-limit? [ drop - "~" over class word-name "~" 3append + "~" over class name>> "~" 3append swap present-text ] [ over recursion-check get memq? [ @@ -166,7 +166,7 @@ M: curry >pprint-sequence ; M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; M: tuple >pprint-sequence tuple>array ; -M: wrapper >pprint-sequence wrapped 1array ; +M: wrapper >pprint-sequence wrapped>> 1array ; M: callstack >pprint-sequence callstack>array ; GENERIC: pprint-narrow? ( obj -- ? ) @@ -190,19 +190,19 @@ M: tuple pprint-narrow? drop t ; M: object pprint* pprint-object ; M: curry pprint* - dup curry-quot callable? [ pprint-object ] [ + dup quot>> callable? [ pprint-object ] [ "( invalid curry )" swap present-text ] if ; M: compose pprint* - dup compose-first over compose-second [ callable? ] both? + dup [ first>> callable? ] [ second>> callable? ] bi and [ pprint-object ] [ "( invalid compose )" swap present-text ] if ; M: wrapper pprint* - dup wrapped word? [ - + dup wrapped>> word? [ + > pprint-word block> ] [ pprint-object ] if ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 298fc83e9d..2921a5cc5d 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -99,7 +99,7 @@ SYMBOL: -> "word-style" set-word-prop : remove-step-into ( word -- ) - building get dup empty? [ drop ] [ nip pop wrapped ] if , ; + building get dup empty? [ drop ] [ nip pop wrapped>> ] if , ; : (remove-breakpoints) ( quot -- newquot ) [ @@ -139,7 +139,7 @@ GENERIC: see ( defspec -- ) [ H{ { font-style italic } } styled-text ] when* ; : seeing-word ( word -- ) - word-vocabulary pprinter-in set ; + vocabulary>> pprinter-in set ; : definer. ( defspec -- ) definer drop pprint-word ; @@ -214,7 +214,7 @@ GENERIC: declarations. ( obj -- ) M: object declarations. drop ; : declaration. ( word prop -- ) - tuck word-name word-prop [ pprint-word ] [ drop ] if ; + tuck name>> word-prop [ pprint-word ] [ drop ] if ; M: word declarations. { diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 2f81207ab5..23a50700b3 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -20,7 +20,7 @@ TUPLE: pprinter last-newline line-count indent ; : ( -- pprinter ) 0 1 0 pprinter boa ; : record-vocab ( word -- ) - word-vocabulary [ pprinter-use get conjoin ] when* ; + vocabulary>> [ pprinter-use get conjoin ] when* ; ! Utility words : line-limit? ( -- ? ) diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index f3436c9a91..9e7ded1836 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays sequences sequences.private +USING: accessors arrays sequences sequences.private kernel kernel.private math assocs quotations.private slots.private ; IN: quotations @@ -12,16 +12,16 @@ M: curry call dup 3 slot swap 4 slot call ; M: compose call dup 3 slot swap 4 slot slip call ; M: wrapper equal? - over wrapper? [ [ wrapped ] bi@ = ] [ 2drop f ] if ; + over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ; UNION: callable quotation curry compose ; M: callable equal? over callable? [ sequence= ] [ 2drop f ] if ; -M: quotation length quotation-array length ; +M: quotation length array>> length ; -M: quotation nth-unsafe quotation-array nth-unsafe ; +M: quotation nth-unsafe array>> nth-unsafe ; : >quotation ( seq -- quot ) >array array>quotation ; inline @@ -38,28 +38,23 @@ M: object literalize ; M: wrapper literalize ; -M: curry length curry-quot length 1+ ; +M: curry length quot>> length 1+ ; M: curry nth - over zero? [ - nip curry-obj literalize - ] [ - >r 1- r> curry-quot nth - ] if ; + over zero? [ nip obj>> literalize ] [ >r 1- r> quot>> nth ] if ; INSTANCE: curry immutable-sequence M: compose length - [ compose-first length ] - [ compose-second length ] bi + ; + [ first>> length ] [ second>> length ] bi + ; -M: compose virtual-seq compose-first ; +M: compose virtual-seq first>> ; M: compose virtual@ - 2dup compose-first length < [ - compose-first + 2dup first>> length < [ + first>> ] [ - [ compose-first length - ] [ compose-second ] bi + [ first>> length - ] [ second>> ] bi ] if ; INSTANCE: compose virtual-sequence diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index f2f45b99c9..113d5eabe4 100755 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -1,9 +1,13 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math strings sequences.private sequences strings -growable strings.private ; +USING: accessors kernel math strings sequences.private sequences +strings growable strings.private ; IN: sbufs +TUPLE: sbuf +{ "underlying" string } +{ "length" array-capacity } ; + sbuf ( string length -- sbuf ) @@ -14,9 +18,10 @@ PRIVATE> : ( n -- sbuf ) 0 0 string>sbuf ; inline M: sbuf set-nth-unsafe - underlying >r >r >fixnum r> >fixnum r> set-string-nth ; + [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; -M: sbuf new-sequence drop [ 0 ] keep >fixnum string>sbuf ; +M: sbuf new-sequence + drop [ 0 ] [ >fixnum ] bi string>sbuf ; : >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline @@ -35,8 +40,8 @@ M: string new-resizable drop ; M: string like drop dup string? [ dup sbuf? [ - dup length over underlying length number= [ - underlying dup reset-string-hashcode + dup length over underlying>> length number= [ + underlying>> dup reset-string-hashcode ] [ >string ] if diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index 3e2f899774..d47ef7b9bb 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private math namespaces +USING: accessors arrays kernel kernel.private math namespaces sequences strings words effects generic generic.standard classes slots.private combinators slots ; IN: slots.deprecated @@ -21,7 +21,7 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ; [ set-reader-props ] 2keep dup slot-spec-offset over slot-spec-reader - rot slot-spec-type reader-quot + rot slot-spec-class reader-quot define-slot-word ] [ 2drop @@ -62,7 +62,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; >r [ swap "set-" % % "-" % % ] "" make r> create ; : (simple-slot-word) ( class name -- class name vocab ) - over word-vocabulary >r >r word-name r> r> ; + over vocabulary>> >r >r name>> r> r> ; : simple-reader-word ( class name -- word ) (simple-slot-word) reader-word ; @@ -70,26 +70,8 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : simple-writer-word ( class name -- word ) (simple-slot-word) writer-word ; -: short-slot ( class name # -- spec ) - >r object bootstrap-word over r> f f - 2over simple-reader-word over set-slot-spec-reader - -rot simple-writer-word over set-slot-spec-writer ; - -: long-slot ( spec # -- spec ) - >r [ dup array? [ first2 create ] when ] map first4 r> - -rot ; - -: simple-slots ( class slots base -- specs ) - over length [ + ] with map [ - { - { [ over not ] [ 2drop f ] } - { [ over string? ] [ >r dupd r> short-slot ] } - { [ over array? ] [ long-slot ] } - } cond - ] 2map sift nip ; - -: slot-of-reader ( reader specs -- spec/f ) - [ slot-spec-reader eq? ] with find nip ; - -: slot-of-writer ( writer specs -- spec/f ) - [ slot-spec-writer eq? ] with find nip ; +: deprecated-slots ( class slot-specs -- slot-specs' ) + [ + 2dup name>> simple-reader-word >>reader + 2dup name>> simple-writer-word >>writer + ] map nip ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 8cd86606bc..2b9631695a 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -92,11 +92,11 @@ HELP: slot-spec $nl "The slots of a slot specification are:" { $list - { { $link slot-spec-type } " - a " { $link class } " declaring the set of possible values for the slot." } - { { $link slot-spec-name } " - a " { $link string } " identifying the slot." } - { { $link slot-spec-offset } " - an " { $link integer } " offset specifying where the slot value is stored inside instances of the relevant class. This is an implementation detail." } - { { $link slot-spec-reader } " - a " { $link word } " for reading the value of this slot." } - { { $link slot-spec-writer } " - a " { $link word } " for writing the value of this slot." } + { { $snippet "name" } " - a " { $link string } " identifying the slot." } + { { $snippet "offset" } " - an " { $link integer } " offset specifying where the slot value is stored inside instances of the relevant class. This is an implementation detail." } + { { $snippet "class" } " - a " { $link class } " declaring the set of possible values for the slot." } + { { $snippet "initial" } " - an initial value for the slot." } + { { $snippet "read-only" } " - a boolean indicating whether the slot is read only, or can be written to." } } } ; HELP: define-typecheck @@ -111,7 +111,7 @@ HELP: define-typecheck } "It checks if the top of the stack is an instance of " { $snippet "class" } ", and if so, executes the quotation. Delegation is respected." } -{ $notes "This word is used internally to wrap low-level code that does not do type-checking in safe user-visible words. For example, see how " { $link word-name } " is implemented." } ; +{ $notes "This word is used internally to wrap unsafe low-level code in a type-checking stub." } ; HELP: define-slot-word { $values { "class" class } { "slot" "a positive integer" } { "word" word } { "quot" quotation } } diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor new file mode 100644 index 0000000000..16196bf844 --- /dev/null +++ b/core/slots/slots-tests.factor @@ -0,0 +1,18 @@ +IN: slots.tests +USING: math accessors slots strings generic.standard kernel tools.test ; + +TUPLE: r/w-test foo ; + +TUPLE: r/o-test { "foo" read-only: t } ; + +[ r/o-test new 123 >>foo ] [ no-method? ] must-fail-with + +TUPLE: decl-test { "foo" integer } ; + +[ decl-test new 1.0 >>foo ] [ bad-slot-value? ] must-fail-with + +TUPLE: hello length ; + +[ 3 ] [ "xyz" length>> ] unit-test + +[ "xyz" 4 >>length ] [ no-method? ] must-fail-with diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 402c4e6b53..ff66a77544 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -2,12 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math namespaces sequences strings words effects generic generic.standard -classes slots.private combinators accessors ; +classes slots.private combinators accessors words ; IN: slots -TUPLE: slot-spec type name offset reader writer ; +TUPLE: slot-spec name offset class initial read-only reader writer ; -C: slot-spec +: ( -- slot-spec ) + slot-spec new + object bootstrap-word >>class ; : define-typecheck ( class generic quot -- ) [ @@ -15,9 +17,13 @@ C: slot-spec create-method ] dip define ; -: define-slot-word ( class slot word quot -- ) +: define-slot-word ( class offset word quot -- ) rot >fixnum prefix define-typecheck ; +: create-accessor ( name effect -- word ) + >r "accessors" create dup r> + "declared-effect" set-word-prop ; + : reader-quot ( decl -- quot ) [ \ slot , @@ -25,15 +31,14 @@ C: slot-spec [ drop ] [ 1array , \ declare , ] if ] [ ] make ; -: create-accessor ( name effect -- word ) - >r "accessors" create dup r> - "declared-effect" set-word-prop ; - : reader-word ( name -- word ) ">>" append (( object -- value )) create-accessor ; -: define-reader ( class slot name decl -- ) - [ reader-word ] dip reader-quot define-slot-word ; +: define-reader ( class slot-spec -- ) + [ offset>> ] + [ name>> reader-word ] + [ class>> reader-quot ] + tri define-slot-word ; : writer-word ( name -- word ) "(>>" swap ")" 3append (( value object -- )) create-accessor ; @@ -50,22 +55,25 @@ ERROR: bad-slot-value value object index ; ] if ] [ ] make ; -: define-writer ( class slot name decl -- ) - [ writer-word ] dip writer-quot define-slot-word ; +: define-writer ( class slot-spec -- ) + [ offset>> ] + [ name>> writer-word ] + [ class>> writer-quot ] + tri define-slot-word ; : setter-word ( name -- word ) ">>" prepend (( object value -- object )) create-accessor ; -: define-setter ( name -- ) - dup setter-word dup deferred? [ +: define-setter ( slot-spec -- ) + name>> dup setter-word dup deferred? [ [ \ over , swap writer-word , ] [ ] make define-inline ] [ 2drop ] if ; : changer-word ( name -- word ) "change-" prepend (( object quot -- object )) create-accessor ; -: define-changer ( name -- ) - dup changer-word dup deferred? [ +: define-changer ( slot-spec -- ) + name>> dup changer-word dup deferred? [ [ [ over >r >r ] % over reader-word , @@ -75,15 +83,63 @@ ERROR: bad-slot-value value object index ; ] [ 2drop ] if ; : define-slot-methods ( class slot-spec -- ) - { - [ [ drop ] [ name>> ] bi* define-changer ] - [ [ drop ] [ name>> ] bi* define-setter ] - [ [ offset>> ] [ name>> ] [ type>> ] tri define-reader ] - [ [ offset>> ] [ name>> ] [ type>> ] tri define-writer ] - } 2cleave ; + [ define-reader ] + [ + dup read-only>> [ 2drop ] [ + [ define-setter drop ] + [ define-changer drop ] + [ define-writer ] + 2tri + ] if + ] 2bi ; : define-accessors ( class specs -- ) [ define-slot-methods ] with each ; +: define-protocol-slot ( name -- ) + { + [ reader-word drop ] + [ writer-word drop ] + [ setter-word drop ] + [ changer-word drop ] + } cleave ; + +GENERIC: make-slot ( desc -- slot-spec ) + +M: string make-slot + + swap >>name ; + +: peel-off-name ( slot-spec array -- slot-spec array ) + [ first >>name ] [ rest ] bi ; inline + +: peel-off-class ( slot-spec array -- slot-spec array ) + dup empty? [ + ! We'd use class? here, but during bootstrap, we sometimes + ! create slots whose class hasn't been defined yet. + dup first name>> ":" tail? not [ + [ first >>class ] [ rest ] bi + ] when + ] unless ; + +: peel-off-attributes ( slot-spec array -- slot-spec array ) + dup empty? [ + unclip { + { initial: [ [ first >>initial ] [ rest ] bi ] } + { read-only: [ [ first >>read-only ] [ rest ] bi ] } + } case + ] unless ; + +M: array make-slot + + swap + peel-off-name + peel-off-class + [ dup empty? not ] [ peel-off-attributes ] [ ] while drop ; + +: make-slots ( slots base -- specs ) + over length [ + ] with map + [ [ make-slot ] dip >>offset ] 2map ; + : slot-named ( name specs -- spec/f ) [ slot-spec-name = ] with find nip ; diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index dac1c08e46..1a2491328c 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math sequences vectors math.order -sequences sequences.private growable math.order ; +USING: accessors arrays kernel math sequences vectors math.order +sequences sequences.private math.order ; IN: sorting DEFER: sort @@ -34,7 +34,7 @@ DEFER: sort : merge ( sorted1 sorted2 quot -- result ) >r [ [ ] bi@ ] 2keep r> rot length rot length + - [ (merge) ] keep underlying ; inline + [ (merge) ] [ underlying>> ] bi ; inline : conquer ( first second quot -- result ) [ tuck >r >r sort r> r> sort ] keep merge ; inline diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 1484737277..8ff5a7caf4 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.private sequences kernel.private +USING: accessors kernel math.private sequences kernel.private math sequences.private slots.private byte-arrays alien.accessors ; IN: strings @@ -30,6 +30,9 @@ M: string hashcode* nip dup string-hashcode [ ] [ dup rehash-string string-hashcode ] ?if ; +M: string length + length>> ; + M: string nth-unsafe >r >fixnum r> string-nth ; @@ -38,7 +41,7 @@ M: string set-nth-unsafe >r >fixnum >r >fixnum r> r> set-string-nth ; M: string clone - (clone) dup string-aux clone over set-string-aux ; + (clone) [ clone ] change-aux ; M: string resize resize-string ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index db1b875eb6..eb72e42c2b 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -547,8 +547,46 @@ HELP: PREDICATE: HELP: TUPLE: { $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. The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." } ; +{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot specifiers" } } +{ $description "Defines a new tuple class." +$nl +"The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." +$nl +"Slot specifiers take one of the following three forms:" +{ $list + { { $snippet "name" } " - a slot which can hold any object, with no attributes" } + { { $snippet "{ \"name\" attributes... }" } " - a slot which can hold any object, with optional attributes" } + { { $snippet "{ \"name\" class attributes... }" } " - a slot specialized to a specific class, with optional attributes" } +} +"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only: } "." } +{ $examples + "A simple tuple class:" + { $code "TUPLE: color red green blue ;" } + "Declaring slots to be integer-valued:" + { $code "TUPLE: color" "{ \"red\" integer }" "{ \"green\" integer }" "{ \"blue\" integer } ;" } + "An example mixing short and long slot specifiers:" + { $code "TUPLE: person" "{ \"age\" integer initial: 0 }" "{ \"department\" string initial: \"Marketing\" }" "manager ;" } +} ; + +HELP: initial: +{ $syntax "TUPLE: ... { \"slot\" initial: value } ... ;" } +{ $values { "slot" "a slot name" } { "value" "any literal" } } +{ $description "Specifies an initial value for a tuple slot." } ; + +HELP: read-only: +{ $syntax "TUPLE: ... { \"slot\" read-only: ? } ... ;" } +{ $values { "slot" "a slot name" } { "?" "a boolean" } } +{ $description "Defines a tuple slot to be read-only. If a tuple has read-only slots, instances of the tuple should only be created by calling " { $link boa } ", instead of " { $link new } ". Using " { $link boa } " is the only way to set the value of a read-only slot." } ; + +{ initial: read-only: } related-words + +HELP: SLOT: +{ $syntax "SLOT: name" } +{ $values { "name" "a slot name" } } +{ $description "Defines a protocol slot; that is, defines the accessor words for a slot named " { $snippet "slot" } " without associating it with any specific tuple." } +{ $notes + "Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass." +} ; HELP: ERROR: { $syntax "ERROR: class slots... ;" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 4d4b81d00e..5257fb5e55 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -8,7 +8,7 @@ generic.standard generic.math generic.parser classes io.files vocabs float-arrays classes.parser classes.union classes.intersection classes.mixin classes.predicate classes.singleton classes.tuple.parser compiler.units -combinators debugger effects.parser ; +combinators debugger effects.parser slots ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -166,6 +166,10 @@ IN: bootstrap.syntax parse-tuple-definition define-tuple-class ] define-syntax + "SLOT:" [ + scan define-protocol-slot + ] define-syntax + "C:" [ CREATE-WORD scan-word check-tuple-class @@ -208,4 +212,8 @@ IN: bootstrap.syntax not-in-a-method-error ] if ] define-syntax + + "initial:" "syntax" lookup define-symbol + + "read-only:" "syntax" lookup define-symbol ] with-compilation-unit diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index 4a6b41f863..b54b2bc91a 100755 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -3,6 +3,10 @@ USING: arrays kernel math sequences sequences.private growable ; IN: vectors +TUPLE: vector +{ "underlying" array } +{ "length" array-capacity } ; + vector ( array length -- vector ) diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 9699844192..2f0d061499 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -11,10 +11,7 @@ $nl "Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "vocabulary-search" } ")." { $subsection create } { $subsection create-in } -{ $subsection lookup } -"Words can output their name and vocabulary:" -{ $subsection word-name } -{ $subsection word-vocabulary } ; +{ $subsection lookup } ; ARTICLE: "uninterned-words" "Uninterned words" "A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "." @@ -103,8 +100,6 @@ ARTICLE: "word-props" "Word properties" "Each word has a hashtable of properties." { $subsection word-prop } { $subsection set-word-prop } -{ $subsection word-props } -{ $subsection set-word-props } "The stack effect of the above two words is designed so that it is most convenient when " { $snippet "name" } " is a literal pushed on the stack right before executing this word." $nl "The following are some of the properties used by the library:" @@ -159,9 +154,8 @@ $nl } ; ARTICLE: "word.private" "Word implementation details" -"Primitive definition accessors:" -{ $subsection word-def } -{ $subsection set-word-def } +"The " { $snippet "def" } " slot of a word holds a " { $link quotation } " instance that is called when the word is executed." +$nl "An " { $emphasis "XT" } " (execution token) is the machine code address of a word:" { $subsection word-xt } ; @@ -189,10 +183,6 @@ $nl ABOUT: "words" -HELP: compiled? ( word -- ? ) -{ $values { "word" word } { "?" "a boolean" } } -{ $description "Tests if a word has been compiled." } ; - HELP: execute ( word -- ) { $values { "word" word } } { $description "Executes a word." } @@ -200,26 +190,6 @@ HELP: execute ( word -- ) { $example "USING: kernel io words ;" "IN: scratchpad" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; -HELP: word-props ( word -- props ) -{ $values { "word" word } { "props" "an assoc" } } -{ $description "Outputs a word's property table." } ; - -HELP: set-word-props ( props word -- ) -{ $values { "props" "an assoc" } { "word" word } } -{ $description "Sets a word's property table." } -{ $notes "The given assoc must not be a literal, since it will be mutated by future calls to " { $link set-word-prop } "." } -{ $side-effects "word" } ; - -HELP: word-def ( word -- obj ) -{ $values { "word" word } { "obj" object } } -{ $description "Outputs a word's primitive definition." } ; - -HELP: set-word-def ( obj word -- ) -{ $values { "obj" object } { "word" word } } -{ $description "Sets a word's primitive definition." } -$low-level-note -{ $side-effects "word" } ; - HELP: deferred { $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ; diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 13be1adb69..3f8c492aff 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -37,7 +37,7 @@ DEFER: plist-test ] with-scope [ "test-scope" ] [ - "test-scope" "scratchpad" lookup word-name + "test-scope" "scratchpad" lookup name>> ] unit-test [ t ] [ vocabs array? ] unit-test @@ -120,7 +120,7 @@ DEFER: x [ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test [ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test -[ "test-last" ] [ word word-name ] unit-test +[ "test-last" ] [ word name>> ] unit-test ! regression SYMBOL: quot-uses-a diff --git a/core/words/words.factor b/core/words/words.factor index d17377fdca..9bf006fa16 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions graphs assocs kernel kernel.private -slots.private math namespaces sequences strings vectors sbufs -quotations assocs hashtables sorting words.private vocabs -math.order sets ; +USING: accessors arrays definitions graphs assocs kernel +kernel.private slots.private math namespaces sequences strings +vectors sbufs quotations assocs hashtables sorting words.private +vocabs math.order sets ; IN: words : word ( -- word ) \ word get-global ; @@ -15,37 +15,36 @@ GENERIC: execute ( word -- ) M: word execute (execute) ; M: word <=> - [ dup word-name swap word-vocabulary 2array ] compare ; + [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ; M: word definer drop \ : \ ; ; -M: word definition word-def ; +M: word definition def>> ; ERROR: undefined ; PREDICATE: deferred < word ( obj -- ? ) - word-def [ undefined ] = ; + def>> [ undefined ] = ; M: deferred definer drop \ DEFER: f ; M: deferred definition drop f ; PREDICATE: symbol < word ( obj -- ? ) - dup 1array swap word-def sequence= ; + [ def>> ] [ [ ] curry ] bi sequence= ; M: symbol definer drop \ SYMBOL: f ; M: symbol definition drop f ; PREDICATE: primitive < word ( obj -- ? ) - word-def [ do-primitive ] tail? ; + def>> [ do-primitive ] tail? ; M: primitive definer drop \ PRIMITIVE: f ; M: primitive definition drop f ; -: word-prop ( word name -- value ) swap word-props at ; +: word-prop ( word name -- value ) swap props>> at ; -: remove-word-prop ( word name -- ) - swap word-props delete-at ; +: remove-word-prop ( word name -- ) swap props>> delete-at ; : set-word-prop ( word value name -- ) over - [ pick word-props ?set-at swap set-word-props ] + [ pick props>> ?set-at >>props drop ] [ nip remove-word-prop ] if ; : reset-props ( word seq -- ) [ remove-word-prop ] with each ; @@ -53,7 +52,7 @@ M: primitive definition drop f ; : lookup ( name vocab -- word ) vocab-words at ; : target-word ( word -- target ) - dup word-name swap word-vocabulary lookup ; + [ name>> ] [ vocabulary>> ] bi lookup ; SYMBOL: bootstrapping? @@ -69,7 +68,7 @@ M: word crossref? dup "forgotten" word-prop [ drop f ] [ - word-vocabulary >boolean + vocabulary>> >boolean ] if ; GENERIC: compiled-crossref? ( word -- ? ) @@ -88,13 +87,13 @@ M: array (quot-uses) seq-uses ; M: callable (quot-uses) seq-uses ; -M: wrapper (quot-uses) >r wrapped r> (quot-uses) ; +M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ; : quot-uses ( quot -- assoc ) global [ H{ } clone [ (quot-uses) ] keep ] bind ; M: word uses ( word -- seq ) - word-def quot-uses keys ; + def>> quot-uses keys ; SYMBOL: compiled-crossref @@ -140,7 +139,7 @@ M: object redefined drop ; [ ] like over unxref over redefined - over set-word-def + >>def dup +inlined+ changed-definition dup crossref? [ dup xref ] when drop ; @@ -204,7 +203,7 @@ M: word subwords drop f ; gensym dup rot define ; : reveal ( word -- ) - dup word-name over word-vocabulary dup vocab-words + dup [ name>> ] [ vocabulary>> ] bi dup vocab-words [ ] [ no-vocab ] ?if set-at ; @@ -234,7 +233,7 @@ M: word set-where swap "loc" set-word-prop ; M: word forget* dup "forgotten" word-prop [ drop ] [ [ delete-xref ] - [ [ word-name ] [ word-vocabulary vocab-words ] bi delete-at ] + [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ] [ t "forgotten" set-word-prop ] tri ] if ; @@ -244,6 +243,6 @@ M: word hashcode* M: word literalize ; -: ?word-name ( word -- name ) dup word? [ word-name ] when ; +: ?word-name ( word -- name ) dup word? [ name>> ] when ; : xref-words ( -- ) all-words [ xref ] each ; diff --git a/extra/alias/alias.factor b/extra/alias/alias.factor index f468340e53..a07c981b97 100755 --- a/extra/alias/alias.factor +++ b/extra/alias/alias.factor @@ -7,7 +7,7 @@ M: alias reset-word [ call-next-method ] [ f "alias" set-word-prop ] bi ; M: alias stack-effect - word-def first stack-effect ; + def>> first stack-effect ; : define-alias ( new old -- ) [ 1quotation define-inline ] diff --git a/extra/bit-vectors/bit-vectors.factor b/extra/bit-vectors/bit-vectors.factor index c14b0a5476..a9bee0c2ac 100755 --- a/extra/bit-vectors/bit-vectors.factor +++ b/extra/bit-vectors/bit-vectors.factor @@ -5,15 +5,9 @@ sequences.private growable bit-arrays prettyprint.backend parser accessors ; IN: bit-vectors -TUPLE: bit-vector underlying fill ; - -M: bit-vector underlying underlying>> { bit-array } declare ; - -M: bit-vector set-underlying (>>underlying) ; - -M: bit-vector length fill>> { array-capacity } declare ; - -M: bit-vector set-fill (>>fill) ; +TUPLE: bit-vector +{ "underlying" bit-array } +{ "length" array-capacity } ; base 2 CHAR: \s pad-left write ] keep [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep - [ " " write peek-instruction word-name write " " write ] keep + [ " " write peek-instruction name>> write " " write ] keep nl drop ; : cpu*. ( cpu -- ) diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 5c3f3e13e6..9e93ba7cad 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -167,7 +167,7 @@ M: db ( tuple class query -- tuple ) dup class db-columns [ ", " 0, ] [ dup column-name>> 0, 2, ] interleave from 0, - class word-name 0, + class name>> 0, ] { { } { } { } } nmake >r >r parse-sql 4drop r> r> maybe-make-retryable do-select ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 4f1e950b01..915ad0c648 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: parser generic kernel classes words slots assocs +USING: accessors parser generic kernel classes words slots assocs sequences arrays vectors definitions prettyprint math hashtables sets macros namespaces ; IN: delegate @@ -35,7 +35,7 @@ M: tuple-class group-words define ; : change-word-prop ( word prop quot -- ) - rot word-props swap change-at ; inline + rot props>> swap change-at ; inline : register-protocol ( group class quot -- ) rot \ protocol-consult [ swapd ?set-at ] change-word-prop ; diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index 56d62d8634..6aafe46b4d 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -6,7 +6,7 @@ IN: descriptive ERROR: descriptive-error args underlying word ; M: descriptive-error summary - word>> "The " swap word-name " word encountered an error." + word>> "The " swap name>> " word encountered an error." 3append ; ; M: symbol (parse-factor-quotation) ( object -- ast ) - dup >string swap word-vocabulary ; + dup >string swap vocabulary>> ; M: word (parse-factor-quotation) ( object -- ast ) - dup word-name swap word-vocabulary ; + dup name>> swap vocabulary>> ; M: string (parse-factor-quotation) ( object -- ast ) ; @@ -346,7 +346,7 @@ M: hashtable (parse-factor-quotation) ( object -- ast ) ] { } make ; M: wrapper (parse-factor-quotation) ( object -- ast ) - wrapped dup word-name swap word-vocabulary ; + wrapped dup name>> swap vocabulary>> ; GENERIC: fjsc-parse ( object -- ast ) diff --git a/extra/float-vectors/float-vectors.factor b/extra/float-vectors/float-vectors.factor index d51f0d4e44..293c20c8b5 100755 --- a/extra/float-vectors/float-vectors.factor +++ b/extra/float-vectors/float-vectors.factor @@ -5,15 +5,9 @@ sequences.private growable float-arrays prettyprint.backend parser accessors ; IN: float-vectors -TUPLE: float-vector underlying fill ; - -M: float-vector underlying underlying>> { float-array } declare ; - -M: float-vector set-underlying (>>underlying) ; - -M: float-vector length fill>> { array-capacity } declare ; - -M: float-vector set-fill (>>fill) ; +TUPLE: float-vector +{ "underlying" float-array } +{ "length" array-capacity } ; > = ] with contains? ] with find nip [ first ] [ "No such responder: " swap append throw ] ?if ; : resolve-base-path ( string -- string' ) @@ -46,7 +46,7 @@ IN: furnace : resolve-template-path ( pair -- path ) [ - first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi* + first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi* ] "" make ; GENERIC: modify-query ( query responder -- query' ) diff --git a/extra/furnace/utilities/utilities.factor b/extra/furnace/utilities/utilities.factor index 20c05d459f..60012d9f4c 100644 --- a/extra/furnace/utilities/utilities.factor +++ b/extra/furnace/utilities/utilities.factor @@ -4,7 +4,7 @@ USING: words kernel sequences splitting ; IN: furnace.utilities : word>string ( word -- string ) - [ word-vocabulary ] [ word-name ] bi ":" swap 3append ; + [ vocabulary>> ] [ name>> ] bi ":" swap 3append ; : words>strings ( seq -- seq' ) [ word>string ] map ; diff --git a/extra/help/help.factor b/extra/help/help.factor index 6c921fe0a2..58949b4cc2 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io kernel namespaces parser prettyprint sequences -words assocs definitions generic quotations effects slots -continuations classes.tuple debugger combinators vocabs +USING: accessors arrays io kernel namespaces parser prettyprint +sequences words assocs definitions generic quotations effects +slots continuations classes.tuple debugger combinators vocabs help.stylesheet help.topics help.crossref help.markup sorting classes vocabs.loader ; IN: help @@ -43,13 +43,13 @@ M: predicate word-help* drop \ $predicate ; : all-errors ( -- seq ) all-words [ error? ] filter sort-articles ; -M: word article-name word-name ; +M: word article-name name>> ; M: word article-title dup [ parsing-word? ] [ symbol? ] bi or [ - word-name + name>> ] [ - [ word-name ] + [ name>> ] [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi append ] if ; diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index eef2463019..82f7f998d7 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences parser kernel help help.markup help.topics -words strings classes tools.vocabs namespaces io +USING: accessors sequences parser kernel help help.markup +help.topics words strings classes tools.vocabs namespaces io io.streams.string prettyprint definitions arrays vectors combinators splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate @@ -27,13 +27,10 @@ IN: help.lint ] unless ; : effect-values ( word -- seq ) - stack-effect dup effect-in swap effect-out append [ - { - { [ dup word? ] [ word-name ] } - { [ dup integer? ] [ drop "object" ] } - { [ dup string? ] [ ] } - } cond - ] map prune natural-sort ; + stack-effect + [ in>> ] [ out>> ] bi append + [ (stack-picture) ] map + prune natural-sort ; : contains-funky-elements? ( element -- ? ) { diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 150a66ec92..692255bdd5 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions generic io kernel assocs hashtables -namespaces parser prettyprint sequences strings io.styles -vectors words math sorting splitting classes -slots vocabs help.stylesheet help.topics vocabs.loader ; +USING: accessors arrays definitions generic io kernel assocs +hashtables namespaces parser prettyprint sequences strings +io.styles vectors words math sorting splitting classes slots +vocabs help.stylesheet help.topics vocabs.loader ; IN: help.markup ! Simple markup language. @@ -178,7 +178,7 @@ M: f print-element drop ; first dup vocab-name swap ($vocab-link) ; : $vocabulary ( element -- ) - first word-vocabulary [ + first vocabulary>> [ "Vocabulary" $heading nl dup ($vocab-link) ] when* ; @@ -230,7 +230,7 @@ M: f print-element drop ; GENERIC: ($instance) ( element -- ) M: word ($instance) - dup word-name a/an write bl ($link) ; + dup name>> a/an write bl ($link) ; M: string ($instance) dup a/an write bl $snippet ; diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor index cfa576d56f..9412fde423 100644 --- a/extra/html/templates/chloe/syntax/syntax.factor +++ b/extra/html/templates/chloe/syntax/syntax.factor @@ -38,7 +38,7 @@ MEMO: chloe-name ( string -- name ) : CHLOE-SINGLETON: scan-word - [ word-name ] [ '[ , singleton-component-tag ] ] bi + [ name>> ] [ '[ , singleton-component-tag ] ] bi define-chloe-tag ; parsing @@ -56,6 +56,6 @@ MEMO: chloe-name ( string -- name ) : CHLOE-TUPLE: scan-word - [ word-name ] [ '[ , tuple-component-tag ] ] bi + [ name>> ] [ '[ , tuple-component-tag ] ] bi define-chloe-tag ; parsing diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 43507046d6..d6c3d633b2 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -80,7 +80,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; ] } 1&& ; : (flatten) ( quot -- ) - [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ; + [ dup flattenable? [ def>> (flatten) ] [ , ] if ] each ; : retain-stack-overflow? ( error -- ? ) { "kernel-error" 14 f f } = ; diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor index dee5c32349..52bee63850 100644 --- a/extra/io/unix/sockets/secure/secure-tests.factor +++ b/extra/io/unix/sockets/secure/secure-tests.factor @@ -33,7 +33,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ; "127.0.0.1" "port" get ?promise ascii drop contents ] with-secure-context ; -[ ] [ [ class word-name write ] server-test ] unit-test +[ ] [ [ class name>> write ] server-test ] unit-test [ "secure" ] [ client-test ] unit-test diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 3a379de78f..a7771111db 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,4 +1,4 @@ -USING: system words sequences vocabs.loader ; +USING: accessors system words sequences vocabs.loader ; { "io.unix.backend" @@ -10,4 +10,4 @@ USING: system words sequences vocabs.loader ; "io.unix.pipes" } [ require ] each -"io.unix." os word-name append require +"io.unix." os name>> append require diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index b56473a0a9..dce589dc9e 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -41,7 +41,7 @@ SYMBOL: terms nip number>string ] [ num-alt. - swap [ word-name ] map "." join + swap [ name>> ] map "." join append ] if ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 49eec6d652..46873d016c 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -48,7 +48,7 @@ PREDICATE: local-reader < word "local-reader?" word-prop ; PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) - dup word-name "!" append f + dup name>> "!" append f [ t "local-writer?" set-word-prop ] keep [ "local-writer" set-word-prop ] 2keep [ swap "local-reader" set-word-prop ] keep ; @@ -187,15 +187,15 @@ M: object local-rewrite* , ; : make-local ( name -- word ) "!" ?tail [ - dup dup word-name set + dup dup name>> set ] [ ] if - dup dup word-name set ; + dup dup name>> set ; : make-locals ( seq -- words assoc ) [ [ make-local ] map ] H{ } make-assoc ; : make-local-word ( name -- word ) - dup dup word-name set ; + dup dup name>> set ; : push-locals ( assoc -- ) use get push ; diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 5168e7fcd2..569de2b9f7 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -23,7 +23,7 @@ SYMBOL: log-service : log-message ( msg word level -- ) check-log-message log-service get dup [ - [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip + [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip 4array "log-message" send-to-log-server ] [ 4drop diff --git a/extra/logging/parser/parser-docs.factor b/extra/logging/parser/parser-docs.factor index dc80f9e87f..76c7ab6c90 100644 --- a/extra/logging/parser/parser-docs.factor +++ b/extra/logging/parser/parser-docs.factor @@ -3,7 +3,7 @@ USING: help.markup help.syntax assocs logging math calendar ; HELP: parse-log { $values { "lines" "a sequence of strings" } { "entries" "a sequence of log entries" } } -{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where" +{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level name>> message }" } ", where" { $list { { $snippet "timestamp" } " is a " { $link timestamp } } { { $snippet "level" } " is a log level; see " { $link "logging.levels" } } diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index 326661fee5..76162c666a 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -19,7 +19,7 @@ SYMBOL: multiline : 'log-level' ( -- parser ) log-levels [ - [ word-name token ] keep [ nip ] curry <@ + [ name>> token ] keep [ nip ] curry <@ ] map ; : 'word-name' ( -- parser ) diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index ec30b2f27c..d13ae616be 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -28,7 +28,7 @@ SYMBOL: log-files : multiline-header 20 CHAR: - ; foldable -: (write-message) ( msg word-name level multi? -- ) +: (write-message) ( msg name>> level multi? -- ) [ "[" write multiline-header write "] " write ] [ @@ -36,7 +36,7 @@ SYMBOL: log-files ] if write bl write ": " write print ; -: write-message ( msg word-name level -- ) +: write-message ( msg name>> level -- ) rot harvest { { [ dup empty? ] [ 3drop ] } { [ dup length 1 = ] [ first -rot f (write-message) ] } @@ -47,7 +47,7 @@ SYMBOL: log-files } cond ; : (log-message) ( msg -- ) - #! msg: { msg word-name level service } + #! msg: { msg name>> level service } first4 log-stream [ write-message flush ] with-output-stream* ; : try-dispose ( stream -- ) diff --git a/extra/math/complex/complex.factor b/extra/math/complex/complex.factor index 588f34d3fc..cef0676d12 100755 --- a/extra/math/complex/complex.factor +++ b/extra/math/complex/complex.factor @@ -1,13 +1,16 @@ -! Copyright (C) 2006 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: math.complex.private -USING: kernel kernel.private math math.private +USING: accessors kernel kernel.private math math.private math.libm math.functions prettyprint.backend arrays math.functions.private sequences parser ; +IN: math.complex.private M: real real-part ; M: real imaginary-part drop 0 ; +M: complex real-part real>> ; +M: complex imaginary-part imaginary>> ; + M: complex absq >rect [ sq ] bi@ + ; : 2>rect ( x y -- xr yr xi yi ) diff --git a/extra/math/ratios/ratios-docs.factor b/extra/math/ratios/ratios-docs.factor index b780a7c322..903017e371 100755 --- a/extra/math/ratios/ratios-docs.factor +++ b/extra/math/ratios/ratios-docs.factor @@ -27,11 +27,11 @@ HELP: ratio HELP: rational { $class-description "The class of rational numbers, a disjoint union of integers and ratios." } ; -HELP: numerator ( a/b -- a ) +HELP: numerator { $values { "a/b" rational } { "a" integer } } { $description "Outputs the numerator of a rational number. Acts as the identity on integers." } ; -HELP: denominator ( a/b -- b ) +HELP: denominator { $values { "a/b" rational } { "b" "a positive integer" } } { $description "Outputs the denominator of a rational number. Always outputs 1 with integers." } ; diff --git a/extra/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor index 43cbc3fc10..b71a34022a 100755 --- a/extra/math/ratios/ratios.factor +++ b/extra/math/ratios/ratios.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2006 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel kernel.private math math.functions math.private ; IN: math.ratios -USING: kernel kernel.private math math.functions math.private ; : >fraction ( a/b -- a b ) dup numerator swap denominator ; inline @@ -37,6 +37,9 @@ M: ratio >fixnum >fraction /i >fixnum ; M: ratio >bignum >fraction /i >bignum ; M: ratio >float >fraction /f ; +M: ratio numerator numerator>> ; +M: ratio denominator denominator>> ; + M: ratio < scale < ; M: ratio <= scale <= ; M: ratio > scale > ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index fe6945d3f7..96a03bd806 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -157,7 +157,7 @@ M: method-body crossref? "forgotten" word-prop not ; : method-word-name ( specializer generic -- string ) - [ word-name % "-" % unparse % ] "" make ; + [ name>> % "-" % unparse % ] "" make ; : method-word-props ( specializer generic -- assoc ) [ diff --git a/extra/odbc/odbc.factor b/extra/odbc/odbc.factor index 0bcd639bc1..17eab5b0a4 100644 --- a/extra/odbc/odbc.factor +++ b/extra/odbc/odbc.factor @@ -227,7 +227,7 @@ C: column { SQL-DOUBLE [ *double ] } { SQL-TINYINT [ *char ] } { SQL-BIGINT [ *longlong ] } - [ nip [ "Unknown SQL Type: " % word-name % ] "" make ] + [ nip [ "Unknown SQL Type: " % name>> % ] "" make ] } case ; TUPLE: field value column ; @@ -245,7 +245,7 @@ C: field r> drop r> [ "SQLGetData Failed for Column: " % dup column-name % - " of type: " % dup column-type word-name % + " of type: " % dup column-type name>> % ] "" make swap ] if ; diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index ac7080d451..e3740f9cba 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -86,7 +86,7 @@ M: #label node>quot [ dup param>> literalize , dup #label-loop? "#loop: " "#label: " ? - over param>> word-name append comment, + over param>> name>> append comment, ] 2keep node-child swap dataflow>quot , \ call , ; @@ -106,7 +106,7 @@ M: #r> node>quot nip out-d>> length \ r> % ; M: object node>quot [ - dup class word-name % + dup class name>> % " " % dup param>> unparse % " " % @@ -163,7 +163,7 @@ SYMBOL: node-count dataflow optimize dataflow>report ; : word-optimize-report ( word -- report ) - word-def quot-optimize-report ; + def>> quot-optimize-report ; : report. ( report -- ) [ diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor index 865ece333c..037427c6a9 100755 --- a/extra/optimizer/report/report.factor +++ b/extra/optimizer/report/report.factor @@ -16,7 +16,7 @@ IN: optimizer.report ] tabular-output ; : optimizer-report ( -- ) - all-words [ compiled? ] filter + all-words [ compiled>> ] filter [ dup [ word-dataflow nip 1 count-optimization-passes diff --git a/extra/present/present.factor b/extra/present/present.factor index d3aec20d80..162a90122e 100644 --- a/extra/present/present.factor +++ b/extra/present/present.factor @@ -10,7 +10,7 @@ M: timestamp present timestamp>string ; M: string present ; -M: word present word-name ; +M: word present name>> ; M: effect present effect>string ; diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index fc8ba9821c..e59d48d439 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -128,7 +128,7 @@ M: array noise [ noise ] map vsum ; GENERIC: word-noise-factor ( word -- factor ) M: word word-noise-factor - word-def quot-noise-factor ; + def>> quot-noise-factor ; M: lambda-word word-noise-factor "lambda" word-prop quot-noise-factor ; diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor index 51eae24333..4ab75d5f4c 100755 --- a/extra/reports/optimizer/optimizer.factor +++ b/extra/reports/optimizer/optimizer.factor @@ -16,7 +16,7 @@ IN: report.optimizer ] tabular-output ; inline : optimizer-measurements ( -- alist ) - all-words [ compiled? ] filter + all-words [ compiled>> ] filter [ dup [ word-dataflow nip 1 count-optimization-passes diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 89ad6fe2d0..e3d13108ad 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -189,7 +189,7 @@ C: relation-definition > ) { { "relate" [ ] } { "id-word" [ "-relation" append ] } @@ -199,14 +199,14 @@ C: relation-definition { "objects" [ "-objects" append ] } } case ; -: choose-word-name ( relation-definition given-word-name word-type -- word-name ) +: choose-word-name ( relation-definition given-word-name word-type -- name>> ) over string? [ drop nip ] [ nip [ relate>> ] dip default-word-name ] if ; -: (define-relation-word) ( id-word word-name definition -- id-word ) +: (define-relation-word) ( id-word name>> definition -- id-word ) >r create-in over [ execute ] curry r> compose define ; : define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word ) @@ -225,7 +225,7 @@ C: relation-definition 2drop ; : define-id-word ( relation-definition id-word -- ) - [ relate>> ] dip tuck word-vocabulary + [ relate>> ] dip tuck vocabulary>> [ ensure-context ensure-relation ] 2curry define ; : create-id-word ( relation-definition -- id-word ) diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index fcf57714d6..dc34920bbd 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -168,21 +168,21 @@ M: string (serialize) ( obj -- ) [ CHAR: G write1 [ add-object ] - [ word-def (serialize) ] - [ word-props (serialize) ] + [ def>> (serialize) ] + [ props>> (serialize) ] tri ] serialize-shared ; : serialize-word ( word -- ) CHAR: w write1 - [ word-name (serialize) ] - [ word-vocabulary (serialize) ] + [ name>> (serialize) ] + [ vocabulary>> (serialize) ] bi ; M: word (serialize) ( obj -- ) { { [ dup t eq? ] [ serialize-true ] } - { [ dup word-vocabulary not ] [ serialize-gensym ] } + { [ dup vocabulary>> not ] [ serialize-gensym ] } [ serialize-word ] } cond ; diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index d6016f280c..6f2ca1377a 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel words parser io inspector quotations sequences -prettyprint continuations effects definitions compiler.units -namespaces assocs tools.walker generic ; +USING: accessors kernel words parser io inspector quotations +sequences prettyprint continuations effects definitions +compiler.units namespaces assocs tools.walker generic ; IN: tools.annotations GENERIC: reset ( word -- ) @@ -24,8 +24,8 @@ M: word reset "Cannot annotate a word twice" throw ] when [ - over dup word-def "unannotated-def" set-word-prop - >r dup word-def r> call define + over dup def>> "unannotated-def" set-word-prop + >r dup def>> r> call define ] with-compilation-unit ; inline : word-inputs ( word -- seq ) diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor index 3ff22cb0c6..604e20f9b1 100755 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions assocs io kernel +USING: accessors arrays definitions assocs io kernel math namespaces prettyprint sequences strings io.styles words generic tools.completion quotations parser inspector sorting hashtables vocabs parser source-files ; @@ -10,7 +10,7 @@ IN: tools.crossref smart-usage sorted-definitions. ; : words-matching ( str -- seq ) - all-words [ dup word-name ] { } map>assoc completions ; + all-words [ dup name>> ] { } map>assoc completions ; : apropos ( str -- ) words-matching synopsis-alist reverse definitions. ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 5a20dd8911..d03d3142f7 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -62,7 +62,7 @@ IN: tools.deploy.shaker : strip-word-names ( words -- ) "Stripping word names" show - [ f over set-word-name f swap set-word-vocabulary ] each ; + [ f over set-word-name f swap set-vocabulary>> ] each ; : strip-word-defs ( words -- ) "Stripping symbolic word definitions" show @@ -73,8 +73,8 @@ IN: tools.deploy.shaker "Stripping word properties" show [ [ - word-props swap - '[ , nip member? not ] assoc-filter + props>> swap + '[ drop , member? not ] assoc-filter f assoc-like ] keep set-word-props ] with each ; diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 4ae3666829..b7f7ae97a6 100755 --- a/extra/tools/profiler/profiler.factor +++ b/extra/tools/profiler/profiler.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: words sequences math prettyprint kernel arrays io +USING: accessors words sequences math prettyprint kernel arrays io io.styles namespaces assocs kernel.private strings combinators sorting math.parser vocabs definitions tools.profiler.private continuations generic ; @@ -10,7 +10,7 @@ IN: tools.profiler [ t profiling call ] [ f profiling ] [ ] cleanup ; : counters ( words -- assoc ) - [ dup profile-counter ] { } map>assoc ; + [ dup counter>> ] { } map>assoc ; GENERIC: (profile.) ( obj -- ) @@ -65,7 +65,7 @@ M: method-body (profile.) vocabs [ dup words [ "predicating" word-prop not ] filter - [ profile-counter ] map sum + [ counter>> ] map sum ] { } map>assoc counters. ; : method-profile. ( -- ) diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 0319434570..b3fe97f908 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel combinators vocabs vocabs.loader tools.vocabs io -io.files io.styles help.markup help.stylesheet sequences assocs -help.topics namespaces prettyprint words sorting definitions -arrays inspector sets ; +USING: accessors kernel combinators vocabs vocabs.loader +tools.vocabs io io.files io.styles help.markup help.stylesheet +sequences assocs help.topics namespaces prettyprint words +sorting definitions arrays inspector sets ; IN: tools.vocabs.browser : vocab-status-string ( vocab -- string ) @@ -105,7 +105,7 @@ C: vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map - [ [ word? ] filter [ word-vocabulary ] map ] gather natural-sort + [ [ word? ] filter [ vocabulary>> ] map ] gather natural-sort remove sift [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 41f9f8066d..07a5759af2 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -75,7 +75,7 @@ M: object add-breakpoint ; { [ dup hook-generic? ] [ effective-method (step-into-execute) ] } { [ dup uses \ suspend swap member? ] [ execute break ] } { [ dup primitive? ] [ execute break ] } - [ word-def (step-into-quot) ] + [ def>> (step-into-quot) ] } cond ; \ (step-into-execute) t "step-into?" set-word-prop diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor index f341595969..6a5a4d2c42 100755 --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions kernel sequences strings math assocs -words generic namespaces assocs quotations splitting +USING: accessors arrays definitions kernel sequences strings +math assocs words generic namespaces assocs quotations splitting ui.gestures unicode.case unicode.categories ; IN: ui.commands @@ -54,7 +54,7 @@ GENERIC: command-word ( command -- word ) { { CHAR: - CHAR: \s } } substitute >title ; M: word command-name ( word -- str ) - word-name + name>> "com-" ?head drop dup first Letter? [ rest ] unless (command-name) ; @@ -66,7 +66,7 @@ M: word command-description ( word -- str ) H{ { +nullary+ f } { +listener+ f } { +description+ f } } ; : define-command ( word hash -- ) - [ word-props ] [ default-flags swap assoc-union ] bi* update ; + [ props>> ] [ default-flags swap assoc-union ] bi* update ; : command-quot ( target command -- quot ) dup 1quotation swap +nullary+ word-prop diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 5bba095253..2d696788f2 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math models namespaces +USING: accessors arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser math.vectors classes.tuple classes ui.gadgets boxes calendar alarms symbols combinators sets columns ; @@ -262,7 +262,7 @@ SYMBOL: drag-timer GENERIC: gesture>string ( gesture -- string/f ) : modifiers>string ( modifiers -- string ) - [ word-name ] map concat >string ; + [ name>> ] map concat >string ; M: key-down gesture>string dup key-down-mods modifiers>string diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 48bf01af37..f998822b3b 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -90,7 +90,7 @@ M: listener-operation invoke-command ( target command -- ) GENERIC: word-completion-string ( word -- string ) M: word word-completion-string - word-name ; + name>> ; M: method-body word-completion-string "method-generic" word-prop word-completion-string ; @@ -101,9 +101,9 @@ M: engine-word word-completion-string "engine-generic" word-prop word-completion-string ; : use-if-necessary ( word seq -- ) - over word-vocabulary [ + over vocabulary>> [ 2dup assoc-stack pick = [ 2drop ] [ - >r word-vocabulary vocab-words r> push + >r vocabulary>> vocab-words r> push ] if ] [ 2drop ] if ; diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index bd9dd351a4..558a56f92a 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -109,7 +109,7 @@ GENERIC: com-stack-effect ( obj -- ) M: quotation com-stack-effect infer. ; -M: word com-stack-effect word-def com-stack-effect ; +M: word com-stack-effect def>> com-stack-effect ; [ word? ] \ com-stack-effect H{ { +listener+ t } diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index af1d263351..f432027367 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs ui.tools.interactor ui.tools.listener +USING: accessors assocs ui.tools.interactor ui.tools.listener ui.tools.workspace help help.topics io.files io.styles kernel models namespaces prettyprint quotations sequences sorting source-files definitions strings tools.completion tools.crossref @@ -82,7 +82,7 @@ M: live-search pref-dim* drop { 400 200 } ; >r definition-candidates r> [ synopsis ] ; : word-candidates ( words -- candidates ) - [ dup word-name >lower ] { } map>assoc ; + [ dup name>> >lower ] { } map>assoc ; : ( string words limited? -- gadget ) >r word-candidates r> [ synopsis ] ; @@ -97,7 +97,7 @@ M: live-search pref-dim* drop { 400 200 } ; : show-word-usage ( workspace word -- ) "" over smart-usage f - "Words and methods using " rot word-name append + "Words and methods using " rot name>> append show-titled-popup ; : help-candidates ( seq -- candidates ) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 3fc5d4abcd..dda9a1dc0e 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -383,7 +383,7 @@ SYMBOL: trace-messages? "uint" { "void*" "uint" "long" "long" } "stdcall" [ [ pick - trace-messages? get-global [ dup windows-message-name word-name print flush ] when + trace-messages? get-global [ dup windows-message-name name>> print flush ] when wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if ] ui-try ] alien-callback ; diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor index 7a5dcc36b6..d100d6dbc3 100755 --- a/extra/unicode/script/script.factor +++ b/extra/unicode/script/script.factor @@ -1,4 +1,4 @@ -USING: values kernel sequences assocs io.files +USING: accessors values kernel sequences assocs io.files io.encodings ascii math.ranges io splitting math.parser namespaces byte-arrays locals math sets io.encodings.ascii words compiler.units arrays interval-maps unicode.data ; @@ -14,7 +14,7 @@ SYMBOL: interned : range, ( value key -- ) swap interned get - [ word-name = ] with find nip 2array , ; + [ name>> = ] with find nip 2array , ; : expand-ranges ( assoc -- interval-map ) [ diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor index 080820ebd0..83c3bb5232 100644 --- a/extra/unix/kqueue/kqueue.factor +++ b/extra/unix/kqueue/kqueue.factor @@ -3,7 +3,7 @@ USING: alien.syntax system sequences vocabs.loader words ; IN: unix.kqueue -<< "unix.kqueue." os word-name append require >> +<< "unix.kqueue." os name>> append require >> FUNCTION: int kqueue ( ) ; diff --git a/extra/usa-cities/usa-cities.factor b/extra/usa-cities/usa-cities.factor index 0149c6832b..1fb0b83393 100644 --- a/extra/usa-cities/usa-cities.factor +++ b/extra/usa-cities/usa-cities.factor @@ -21,7 +21,7 @@ ERROR: no-such-state name ; M: no-such-state summary drop "No such state" ; MEMO: string>state ( string -- state ) - dup states [ word-name = ] with find nip + dup states [ name>> = ] with find nip [ ] [ no-such-state ] ?if ; TUPLE: city diff --git a/extra/values/values.factor b/extra/values/values.factor index 6f050fc8f8..7f19898b18 100755 --- a/extra/values/values.factor +++ b/extra/values/values.factor @@ -1,4 +1,4 @@ -USING: kernel parser sequences words effects ; +USING: accessors kernel parser sequences words effects ; IN: values : VALUE: @@ -6,10 +6,10 @@ IN: values (( -- value )) define-declared ; parsing : set-value ( value word -- ) - word-def first set-first ; + def>> first set-first ; : get-value ( word -- value ) - word-def first first ; + def>> first first ; : change-value ( word quot -- ) over >r >r get-value r> call r> set-value ; inline diff --git a/extra/vars/vars.factor b/extra/vars/vars.factor index e3e13be3a9..243cdee2a9 100644 --- a/extra/vars/vars.factor +++ b/extra/vars/vars.factor @@ -7,11 +7,11 @@ USING: kernel parser lexer words namespaces sequences quotations ; IN: vars : define-var-getter ( word -- ) - [ word-name ">" append create-in ] [ [ get ] curry ] bi + [ name>> ">" append create-in ] [ [ get ] curry ] bi (( -- value )) define-declared ; : define-var-setter ( word -- ) - [ word-name ">" prepend create-in ] [ [ set ] curry ] bi + [ name>> ">" prepend create-in ] [ [ set ] curry ] bi (( value -- )) define-declared ; : define-var ( str -- ) diff --git a/extra/windows/messages/messages.factor b/extra/windows/messages/messages.factor index 4c20d0fb42..dea84218a0 100644 --- a/extra/windows/messages/messages.factor +++ b/extra/windows/messages/messages.factor @@ -7,7 +7,7 @@ IN: windows.messages SYMBOL: windows-messages "windows.messages" words -[ word-name "windows-message" head? not ] filter +[ name>> "windows-message" head? not ] filter [ dup execute swap ] { } map>assoc windows-messages set-global diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index e1875bd0c1..91dd1903b4 100755 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -12,7 +12,7 @@ M: process-missing error. "Tag <" write dup process-missing-tag print-name "> not implemented on process process " write - process-missing-process word-name print ; + process-missing-process name>> print ; : run-process ( tag word -- ) 2dup "xtable" word-prop diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor index 9167517bb2..028d9b62ba 100755 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -6,7 +6,7 @@ IN: xmode.code2html : htmlize-tokens ( tokens -- ) [ [ str>> ] [ id>> ] bi [ - escape-string write + > =class span> escape-string write ] [ escape-string write ] if* diff --git a/extra/xmode/tokens/tokens.factor b/extra/xmode/tokens/tokens.factor index 018164dfcf..549362773a 100755 --- a/extra/xmode/tokens/tokens.factor +++ b/extra/xmode/tokens/tokens.factor @@ -8,7 +8,7 @@ SYMBOL: tokens { "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [ create-in dup define-symbol - dup word-name swap + dup name>> swap ] H{ } map>assoc tokens set-global >> -- 2.34.1