diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 0f756e0ad0..71c3fd6ff2 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -10,7 +10,7 @@ M: array c-type ; M: array heap-size unclip heap-size [ * ] reduce ; -M: array c-type-align first c-type c-type-align ; +M: array c-type-align first c-type-align ; M: array c-type-stack-align? drop f ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a9b39f80ab..f44941d88f 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -37,6 +37,7 @@ ERROR: no-c-type name ; dup string? [ (c-type) ] when ] when ; +! C type protocol GENERIC: c-type ( name -- type ) foldable : resolve-pointer-type ( name -- name ) @@ -62,6 +63,60 @@ M: string c-type ( name -- type ) ] ?if ] if ; +GENERIC: c-type-boxer ( name -- boxer ) + +M: c-type c-type-boxer boxer>> ; + +M: string c-type-boxer c-type c-type-boxer ; + +GENERIC: c-type-boxer-quot ( name -- quot ) + +M: c-type c-type-boxer-quot boxer-quot>> ; + +M: string c-type-boxer-quot c-type c-type-boxer-quot ; + +GENERIC: c-type-unboxer ( name -- boxer ) + +M: c-type c-type-unboxer unboxer>> ; + +M: string c-type-unboxer c-type c-type-unboxer ; + +GENERIC: c-type-unboxer-quot ( name -- quot ) + +M: c-type c-type-unboxer-quot unboxer-quot>> ; + +M: string c-type-unboxer-quot c-type c-type-unboxer-quot ; + +GENERIC: c-type-reg-class ( name -- reg-class ) + +M: c-type c-type-reg-class reg-class>> ; + +M: string c-type-reg-class c-type c-type-reg-class ; + +GENERIC: c-type-getter ( name -- quot ) + +M: c-type c-type-getter getter>> ; + +M: string c-type-getter c-type c-type-getter ; + +GENERIC: c-type-setter ( name -- quot ) + +M: c-type c-type-setter setter>> ; + +M: string c-type-setter c-type c-type-setter ; + +GENERIC: c-type-align ( name -- n ) + +M: c-type c-type-align align>> ; + +M: string c-type-align c-type c-type-align ; + +GENERIC: c-type-stack-align? ( name -- ? ) + +M: c-type c-type-stack-align? stack-align?>> ; + +M: string c-type-stack-align? c-type c-type-stack-align? ; + : c-type-box ( n type -- ) dup c-type-reg-class swap c-type-boxer [ "No boxer" throw ] unless* @@ -72,10 +127,6 @@ M: string c-type ( name -- type ) swap c-type-unboxer [ "No unboxer" throw ] unless* %unbox ; -M: string c-type-align c-type c-type-align ; - -M: string c-type-stack-align? c-type c-type-stack-align? ; - GENERIC: box-parameter ( n ctype -- ) M: c-type box-parameter c-type-box ; @@ -107,25 +158,25 @@ GENERIC: heap-size ( type -- size ) foldable M: string heap-size c-type heap-size ; -M: c-type heap-size c-type-size ; +M: c-type heap-size size>> ; GENERIC: stack-size ( type -- size ) foldable M: string stack-size c-type stack-size ; -M: c-type stack-size c-type-size ; +M: c-type stack-size size>> ; GENERIC: byte-length ( seq -- n ) flushable M: byte-array byte-length length ; : c-getter ( name -- quot ) - c-type c-type-getter [ + c-type-getter [ [ "Cannot read struct fields with type" throw ] ] unless* ; : c-setter ( name -- quot ) - c-type c-type-setter [ + c-type-setter [ [ "Cannot write struct fields with type" throw ] ] unless* ; diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor index 2c464cc74c..6f83885d9f 100755 --- a/basis/alien/structs/structs-docs.factor +++ b/basis/alien/structs/structs-docs.factor @@ -1,5 +1,5 @@ IN: alien.structs -USING: alien.c-types strings help.markup help.syntax +USING: accessors alien.c-types strings help.markup help.syntax alien.syntax sequences io arrays slots.deprecated kernel words slots assocs namespaces accessors ; @@ -67,7 +67,7 @@ M: word slot-specs "slots" word-prop ; first dup "writing" word-prop [ slot-specs ] keep $spec-writer ; -M: string slot-specs c-type struct-type-fields ; +M: string slot-specs c-type fields>> ; M: array ($instance) first ($instance) " array" write ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor index bfdcd31b99..8c7d9f9b29 100644 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -7,7 +7,7 @@ C-STRUCT: bar { { "int" 8 } "y" } ; [ 36 ] [ "bar" heap-size ] unit-test -[ t ] [ \ "bar" c-type c-type-getter memq? ] unit-test +[ t ] [ \ "bar" c-type-getter memq? ] unit-test C-STRUCT: align-test { "int" "x" } diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 51283e2956..e6a363941d 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -6,7 +6,7 @@ slots.deprecated alien.c-types cpu.architecture ; IN: alien.structs : align-offset ( offset type -- offset ) - c-type c-type-align align ; + c-type-align align ; : struct-offsets ( specs -- size ) 0 [ @@ -24,7 +24,7 @@ IN: alien.structs [ reader>> ] [ class>> - [ c-getter ] [ c-type c-type-boxer-quot ] bi append + [ c-getter ] [ c-type-boxer-quot ] bi append ] tri define-struct-slot-word ; @@ -44,9 +44,9 @@ IN: alien.structs TUPLE: struct-type size align fields ; -M: struct-type heap-size struct-type-size ; +M: struct-type heap-size size>> ; -M: struct-type c-type-align struct-type-align ; +M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 08da2ae14b..2388d7b8f0 100755 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors init command-line namespaces words debugger io +USING: accessors init namespaces words io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings definitions assocs compiler.errors compiler.units -math.parser generic sets ; +math.parser generic sets debugger command-line ; IN: bootstrap.stage2 SYMBOL: bootstrap-time diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor index 2452b19e11..e460f5558b 100755 --- a/basis/compiler/generator/registers/registers.factor +++ b/basis/compiler/generator/registers/registers.factor @@ -69,23 +69,21 @@ TUPLE: ds-loc n class ; : ( n -- loc ) f ds-loc boa ; -M: ds-loc minimal-ds-loc* ds-loc-n min ; -M: ds-loc operand-class* ds-loc-class ; -M: ds-loc set-operand-class set-ds-loc-class ; +M: ds-loc minimal-ds-loc* n>> min ; M: ds-loc live-loc? - over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ; + over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; ! A retain stack location. TUPLE: rs-loc n class ; : ( n -- loc ) f rs-loc boa ; -M: rs-loc operand-class* rs-loc-class ; -M: rs-loc set-operand-class set-rs-loc-class ; M: rs-loc live-loc? - over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ; + over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; UNION: loc ds-loc rs-loc ; +M: loc operand-class* class>> ; +M: loc set-operand-class (>>class) ; M: loc move-spec drop loc ; INSTANCE: loc value @@ -106,12 +104,12 @@ M: cached set-operand-class vreg>> set-operand-class ; M: cached operand-class* vreg>> operand-class* ; M: cached move-spec drop cached ; M: cached live-vregs* vreg>> live-vregs* ; -M: cached live-loc? cached-loc live-loc? ; +M: cached live-loc? loc>> live-loc? ; M: cached (lazy-load) >r vreg>> r> (lazy-load) ; M: cached lazy-store - 2dup cached-loc live-loc? + 2dup loc>> live-loc? [ "live-locs" get at %move ] [ 2drop ] if ; -M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ; +M: cached minimal-ds-loc* loc>> minimal-ds-loc* ; INSTANCE: cached value @@ -121,48 +119,48 @@ TUPLE: tagged vreg class ; : ( vreg -- tagged ) f tagged boa ; -M: tagged v>operand tagged-vreg v>operand ; -M: tagged set-operand-class set-tagged-class ; -M: tagged operand-class* tagged-class ; +M: tagged v>operand vreg>> v>operand ; +M: tagged set-operand-class (>>class) ; +M: tagged operand-class* class>> ; M: tagged move-spec drop f ; -M: tagged live-vregs* tagged-vreg , ; +M: tagged live-vregs* vreg>> , ; INSTANCE: tagged value ! Unboxed alien pointers TUPLE: unboxed-alien vreg ; C: unboxed-alien -M: unboxed-alien v>operand unboxed-alien-vreg v>operand ; +M: unboxed-alien v>operand vreg>> v>operand ; M: unboxed-alien operand-class* drop simple-alien ; M: unboxed-alien move-spec class ; -M: unboxed-alien live-vregs* unboxed-alien-vreg , ; +M: unboxed-alien live-vregs* vreg>> , ; INSTANCE: unboxed-alien value TUPLE: unboxed-byte-array vreg ; C: unboxed-byte-array -M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ; +M: unboxed-byte-array v>operand vreg>> v>operand ; M: unboxed-byte-array operand-class* drop c-ptr ; M: unboxed-byte-array move-spec class ; -M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ; +M: unboxed-byte-array live-vregs* vreg>> , ; INSTANCE: unboxed-byte-array value TUPLE: unboxed-f vreg ; C: unboxed-f -M: unboxed-f v>operand unboxed-f-vreg v>operand ; +M: unboxed-f v>operand vreg>> v>operand ; M: unboxed-f operand-class* drop \ f ; M: unboxed-f move-spec class ; -M: unboxed-f live-vregs* unboxed-f-vreg , ; +M: unboxed-f live-vregs* vreg>> , ; INSTANCE: unboxed-f value TUPLE: unboxed-c-ptr vreg ; C: unboxed-c-ptr -M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ; +M: unboxed-c-ptr v>operand vreg>> v>operand ; M: unboxed-c-ptr operand-class* drop c-ptr ; M: unboxed-c-ptr move-spec class ; -M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ; +M: unboxed-c-ptr live-vregs* vreg>> , ; INSTANCE: unboxed-c-ptr value diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 0b570907ab..00bdb4b7c9 100755 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types cpu.ppc.assembler cpu.architecture generic -kernel kernel.private math memory namespaces sequences words -assocs compiler.generator compiler.generator.registers -compiler.generator.fixup system layouts classes words.private -alien combinators compiler.constants math.order ; +USING: accessors alien.c-types cpu.ppc.assembler +cpu.architecture generic kernel kernel.private math memory +namespaces sequences words assocs compiler.generator +compiler.generator.registers compiler.generator.fixup system +layouts classes words.private alien combinators +compiler.constants math.order ; IN: cpu.ppc.architecture ! PowerPC register assignments @@ -65,8 +66,8 @@ M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; GENERIC: loc>operand ( loc -- reg n ) -M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ; -M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ; +M: ds-loc loc>operand n>> cells neg ds-reg swap ; +M: rs-loc loc>operand n>> cells neg rs-reg swap ; M: immediate load-literal [ v>operand ] bi@ LOAD ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index eede86085b..1577945118 100755 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,14 +1,15 @@ -USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture -namespaces alien.c-types kernel system combinators ; +USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics +cpu.architecture namespaces alien.c-types kernel system +combinators ; { { [ os macosx? ] [ - 4 "longlong" c-type set-c-type-align - 4 "ulonglong" c-type set-c-type-align - 4 "double" c-type set-c-type-align + 4 "longlong" c-type (>>align) + 4 "ulonglong" c-type (>>align) + 4 "double" c-type (>>align) ] } { [ os linux? ] [ - t "longlong" c-type set-c-type-stack-align? - t "ulonglong" c-type set-c-type-stack-align? + t "longlong" c-type (>>stack-align?) + t "ulonglong" c-type (>>stack-align?) ] } } cond diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 504707777a..6f255893db 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -259,9 +259,9 @@ M: x86.32 %cleanup ( alien-node -- ) M: x86.32 %unwind ( n -- ) %epilogue-later RET ; os windows? [ - cell "longlong" c-type set-c-type-align - cell "ulonglong" c-type set-c-type-align - 4 "double" c-type set-c-type-align + cell "longlong" c-type (>>align) + cell "ulonglong" c-type (>>align) + 4 "double" c-type (>>align) ] unless : (sse2?) ( -- ? ) "Intrinsic" throw ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 0ba3b93730..c1697f1d98 100755 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -174,10 +174,10 @@ USE: cpu.x86.intrinsics ! The ABI for passing structs by value is pretty messed up << "void*" c-type clone "__stack_value" define-primitive-type -stack-params "__stack_value" c-type set-c-type-reg-class >> +stack-params "__stack_value" c-type (>>reg-class) >> : struct-types&offset ( struct-type -- pairs ) - struct-type-fields [ + fields>> [ [ class>> ] [ offset>> ] bi 2array ] map ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 52ad68baf1..69bc685364 100755 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays cpu.x86.assembler +USING: accessors alien alien.c-types arrays cpu.x86.assembler cpu.x86.assembler.private cpu.architecture kernel kernel.private math memory namespaces sequences words compiler.generator compiler.generator.registers compiler.generator.fixup system @@ -16,8 +16,8 @@ HOOK: stack-save-reg cpu ( -- reg ) : reg-stack ( n reg -- op ) swap cells neg [+] ; -M: ds-loc v>operand ds-loc-n ds-reg reg-stack ; -M: rs-loc v>operand rs-loc-n rs-reg reg-stack ; +M: ds-loc v>operand n>> ds-reg reg-stack ; +M: rs-loc v>operand n>> rs-reg reg-stack ; M: int-regs %save-param-reg drop >r stack@ r> MOV ; M: int-regs %load-param-reg drop swap stack@ MOV ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 51ef806ebe..06c410c0e4 100755 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -207,7 +207,7 @@ M: no-case summary M: slice-error error. "Cannot create slice because " write - slice-error-reason print ; + reason>> print ; M: bounds-error summary drop "Sequence index out of bounds" ; @@ -232,14 +232,14 @@ M: immutable summary drop "Sequence is immutable" ; M: redefine-error error. "Re-definition of " write - redefine-error-def . ; + def>> . ; M: undefined summary drop "Calling a deferred word before it has been defined" ; M: no-compilation-unit error. "Attempting to define " write - no-compilation-unit-definition pprint + definition>> pprint " outside of a compilation unit" print ; M: no-vocab summary @@ -299,9 +299,9 @@ M: string expected>string ; M: unexpected error. "Expected " write - dup unexpected-want expected>string write + dup want>> expected>string write " but got " write - unexpected-got expected>string print ; + got>> expected>string print ; M: lexer-error error. [ lexer-dump ] [ error>> error. ] bi ; diff --git a/basis/help/definitions/definitions.factor b/basis/help/definitions/definitions.factor index 4d942ae3a9..e5202e1306 100755 --- a/basis/help/definitions/definitions.factor +++ b/basis/help/definitions/definitions.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: definitions help help.topics help.syntax +USING: accessors definitions help help.topics help.syntax prettyprint.backend prettyprint words kernel effects ; IN: help.definitions @@ -8,30 +8,30 @@ IN: help.definitions M: link definer drop \ ARTICLE: \ ; ; -M: link where link-name article article-loc ; +M: link where name>> article loc>> ; -M: link set-where link-name article set-article-loc ; +M: link set-where name>> article (>>loc) ; -M: link forget* link-name remove-article ; +M: link forget* name>> remove-article ; M: link definition article-content ; M: link synopsis* dup definer. - dup link-name pprint* + dup name>> pprint* article-title pprint* ; M: word-link definer drop \ HELP: \ ; ; -M: word-link where link-name "help-loc" word-prop ; +M: word-link where name>> "help-loc" word-prop ; -M: word-link set-where link-name swap "help-loc" set-word-prop ; +M: word-link set-where name>> swap "help-loc" set-word-prop ; -M: word-link definition link-name "help" word-prop ; +M: word-link definition name>> "help" word-prop ; M: word-link synopsis* dup definer. - link-name dup pprint-word + name>> dup pprint-word stack-effect. ; -M: word-link forget* link-name remove-word-help ; +M: word-link forget* name>> remove-word-help ; diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor index 65120a5d01..42d5ba1781 100755 --- a/basis/help/syntax/syntax.factor +++ b/basis/help/syntax/syntax.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel parser sequences words help help.topics -namespaces vocabs definitions compiler.units ; +USING: accessors arrays kernel parser sequences words help +help.topics namespaces vocabs definitions compiler.units ; IN: help.syntax : HELP: @@ -16,7 +16,6 @@ IN: help.syntax over add-article >link r> remember-definition ; parsing : ABOUT: - scan-object in get vocab dup changed-definition - set-vocab-help ; parsing + scan-object >>help drop ; parsing diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index 745988c077..c52d5e347f 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -34,6 +34,6 @@ SYMBOL: foo ] unit-test [ { "testfile" 2 } ] -[ { "test" 1 } articles get at article-loc ] unit-test +[ { "test" 1 } articles get at loc>> ] unit-test [ ] [ { "test" 1 } remove-article ] unit-test diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index 14a6c3f8ad..cdb32b18ee 100755 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -34,6 +34,8 @@ SYMBOL: article-xref article-xref global [ H{ } assoc-like ] change-at GENERIC: article-name ( topic -- string ) +GENERIC: article-title ( topic -- string ) +GENERIC: article-content ( topic -- content ) GENERIC: article-parent ( topic -- parent ) GENERIC: set-article-parent ( parent topic -- ) @@ -42,7 +44,9 @@ TUPLE: article title content loc ; :
( title content -- article ) f \ article boa ; -M: article article-name article-title ; +M: article article-name title>> ; +M: article article-title title>> ; +M: article article-content content>> ; ERROR: no-article name ; diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 006e0e7881..909b2dcf3b 100755 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -109,7 +109,7 @@ M: output-port stream-write1 M: output-port stream-write dup check-disposed - over length over buffer>> buffer-size > [ + over length over buffer>> size>> > [ [ buffer>> size>> ] [ [ stream-write ] curry ] bi each diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 8decf3251c..97e4557ada 100755 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -63,12 +63,7 @@ HELP: set-model { $values { "value" object } { "model" model } } { $description "Changes the value of a model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ; -{ set-model set-model-value change-model (change-model) } related-words - -HELP: set-model-value ( value model -- ) -{ $values { "value" object } { "model" model } } -{ $description "Changes the value of a model without notifying any observers registered with " { $link add-connection } "." } -{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link set-model } ", which notifies observers." } ; +{ set-model change-model (change-model) } related-words HELP: change-model { $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } } diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index 6342deb79e..93de40d672 100755 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -17,7 +17,7 @@ TUPLE: just-parser p1 ; M: just-parser (compile) ( parser -- quot ) - just-parser-p1 compile-parser just-pattern curry ; + p1>> compile-parser just-pattern curry ; : just ( parser -- parser ) just-parser boa wrap-peg ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 111bcfdafc..8e5e932666 100755 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -105,7 +105,7 @@ M: sbuf pprint* dup "SBUF\" " "\"" pprint-string ; M: pathname pprint* - dup pathname-string "P\" " "\"" pprint-string ; + dup string>> "P\" " "\"" pprint-string ; ! Sequences : nesting-limit? ( -- ? ) diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 49881f2e9f..63a44d85d4 100755 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -172,7 +172,7 @@ M: hook-generic synopsis* [ definer. ] [ seeing-word ] [ pprint-word ] - [ "combination" word-prop hook-combination-var pprint* ] + [ "combination" word-prop var>> pprint* ] [ stack-effect. ] } cleave ; diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index aed476b5c6..13c86ea994 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -205,7 +205,7 @@ TUPLE: text < section string ; swap >>style swap >>string ; -M: text short-section text-string write ; +M: text short-section string>> write ; M: text long-section short-section ; @@ -291,17 +291,13 @@ SYMBOL: next : split-groups ( ? -- ) [ t , ] when ; -M: f section-start-group? drop t ; - -M: f section-end-group? drop f ; - : split-before ( section -- ) - [ section-start-group? prev get section-end-group? and ] + [ start-group?>> prev get [ end-group?>> ] [ t ] if* and ] [ flow? prev get flow? not and ] bi or split-groups ; : split-after ( section -- ) - section-end-group? split-groups ; + [ end-group?>> ] [ f ] if* split-groups ; : group-flow ( seq -- newseq ) [ diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index 55a96c8b7d..a771a35735 100755 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -181,12 +181,12 @@ M: vocab-spec article-parent drop "vocab-index" ; M: vocab-tag >link ; M: vocab-tag article-title - vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ; + name>> "Vocabularies tagged ``" swap "''" 3append ; -M: vocab-tag article-name vocab-tag-name ; +M: vocab-tag article-name name>> ; M: vocab-tag article-content - \ $tagged-vocabs swap vocab-tag-name 2array ; + \ $tagged-vocabs swap name>> 2array ; M: vocab-tag article-parent drop "vocab-index" ; @@ -195,12 +195,12 @@ M: vocab-tag summary article-title ; M: vocab-author >link ; M: vocab-author article-title - vocab-author-name "Vocabularies by " prepend ; + name>> "Vocabularies by " prepend ; -M: vocab-author article-name vocab-author-name ; +M: vocab-author article-name name>> ; M: vocab-author article-content - \ $authored-vocabs swap vocab-author-name 2array ; + \ $authored-vocabs swap name>> 2array ; M: vocab-author article-parent drop "vocab-index" ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 56567fab85..7415bd0eb2 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -210,7 +210,7 @@ M: enum at* M: enum set-at seq>> set-nth ; -M: enum delete-at enum-seq delete-nth ; +M: enum delete-at seq>> delete-nth ; M: enum >alist ( enum -- alist ) seq>> [ length ] keep zip ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index a7770e2eb2..3a92d5193c 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -78,8 +78,8 @@ TUPLE: mixin-instance loc class mixin ; M: mixin-instance equal? { { [ over mixin-instance? not ] [ f ] } - { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } - { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } + { [ 2dup [ class>> ] bi@ = not ] [ f ] } + { [ 2dup [ mixin>> ] bi@ = not ] [ f ] } [ t ] } cond 2nip ; @@ -91,15 +91,14 @@ M: mixin-instance hashcode* swap >>mixin swap >>class ; -M: mixin-instance where mixin-instance-loc ; +M: mixin-instance where loc>> ; -M: mixin-instance set-where set-mixin-instance-loc ; +M: mixin-instance set-where (>>loc) ; M: mixin-instance definer drop \ INSTANCE: f ; M: mixin-instance definition drop f ; M: mixin-instance forget* - dup mixin-instance-class - swap mixin-instance-mixin dup mixin-class? - [ remove-mixin-instance ] [ 2drop ] if ; + [ class>> ] [ mixin>> ] bi + mixin-class? [ remove-mixin-instance ] [ 2drop ] if ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 1d3c061a42..bfa3848186 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -178,7 +178,7 @@ M: condition compute-restarts [ error>> compute-restarts ] [ [ restarts>> ] - [ condition-continuation [ ] curry ] bi + [ continuation>> [ ] curry ] bi { } assoc>map ] bi append ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 15ee233dbc..36cec298bd 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -130,9 +130,9 @@ M: encoder stream-write1 M: encoder stream-write >encoder< decoder-write ; -M: encoder dispose encoder-stream dispose ; +M: encoder dispose stream>> dispose ; -M: encoder stream-flush encoder-stream stream-flush ; +M: encoder stream-flush stream>> stream-flush ; INSTANCE: encoder plain-writer PRIVATE> diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index aa2cd563a5..767c2a1f79 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -56,7 +56,7 @@ ERROR: invalid-source-file-path path ; ] [ 2drop ] if ] assoc-each ; -M: pathname where pathname-string 1 2array ; +M: pathname where string>> 1 2array ; : forget-source ( path -- ) [ @@ -69,7 +69,7 @@ M: pathname where pathname-string 1 2array ; bi ; M: pathname forget* - pathname-string forget-source ; + string>> forget-source ; : rollback-source-file ( file -- ) [ diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index ce84943328..e156832923 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays byte-arrays byte-vectors +USING: accessors alien arrays byte-arrays byte-vectors definitions generic hashtables kernel math namespaces parser lexer sequences strings strings.parser sbufs vectors words quotations io assocs splitting classes.tuple @@ -193,7 +193,7 @@ IN: bootstrap.syntax "))" parse-effect parsed ] define-syntax - "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax + "MAIN:" [ scan-word in get vocab (>>main) ] define-syntax "<<" [ [ diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index fedd6de3b7..1bdbe3ce14 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -16,44 +16,78 @@ source-loaded? docs-loaded? ; swap >>name H{ } clone >>words ; +GENERIC: vocab-name ( vocab-spec -- name ) + GENERIC: vocab ( vocab-spec -- vocab ) M: vocab vocab ; M: object vocab ( name -- vocab ) vocab-name dictionary get at ; +M: vocab vocab-name name>> ; + M: string vocab-name ; +GENERIC: vocab-words ( vocab-spec -- words ) + +M: vocab vocab-words words>> ; + M: object vocab-words vocab vocab-words ; +M: f vocab-words ; + +GENERIC: vocab-help ( vocab-spec -- help ) + +M: vocab vocab-help help>> ; + M: object vocab-help vocab vocab-help ; +M: f vocab-help ; + +GENERIC: vocab-main ( vocab-spec -- main ) + +M: vocab vocab-main main>> ; + M: object vocab-main vocab vocab-main ; +M: f vocab-main ; + +GENERIC: vocab-source-loaded? ( vocab-spec -- ? ) + +M: vocab vocab-source-loaded? source-loaded?>> ; + M: object vocab-source-loaded? vocab vocab-source-loaded? ; +M: f vocab-source-loaded? ; + +GENERIC: set-vocab-source-loaded? ( ? vocab-spec -- ) + +M: vocab set-vocab-source-loaded? (>>source-loaded?) ; + M: object set-vocab-source-loaded? vocab set-vocab-source-loaded? ; +M: f set-vocab-source-loaded? 2drop ; + +GENERIC: vocab-docs-loaded? ( vocab-spec -- ? ) + +M: vocab vocab-docs-loaded? docs-loaded?>> ; + M: object vocab-docs-loaded? vocab vocab-docs-loaded? ; +M: f vocab-docs-loaded? ; + +GENERIC: set-vocab-docs-loaded? ( ? vocab-spec -- ) + +M: vocab set-vocab-docs-loaded? (>>docs-loaded?) ; + M: object set-vocab-docs-loaded? vocab set-vocab-docs-loaded? ; -M: f vocab-words ; - -M: f vocab-source-loaded? ; - -M: f set-vocab-source-loaded? 2drop ; - -M: f vocab-docs-loaded? ; - M: f set-vocab-docs-loaded? 2drop ; -M: f vocab-help ; - : create-vocab ( name -- vocab ) dictionary get [ ] cache ; @@ -90,10 +124,9 @@ TUPLE: vocab-link name ; : ( name -- vocab-link ) vocab-link boa ; -M: vocab-link hashcode* - vocab-link-name hashcode* ; +M: vocab-link hashcode* name>> hashcode* ; -M: vocab-link vocab-name vocab-link-name ; +M: vocab-link vocab-name name>> ; UNION: vocab-spec vocab vocab-link ;