Removing old accessor usages from core and basis

db4
Slava Pestov 2008-08-31 07:45:33 -05:00
parent ca5caafefe
commit 0c304b8fc6
31 changed files with 212 additions and 135 deletions

View File

@ -10,7 +10,7 @@ M: array c-type ;
M: array heap-size unclip heap-size [ * ] reduce ; 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 ; M: array c-type-stack-align? drop f ;

View File

@ -37,6 +37,7 @@ ERROR: no-c-type name ;
dup string? [ (c-type) ] when dup string? [ (c-type) ] when
] when ; ] when ;
! C type protocol
GENERIC: c-type ( name -- type ) foldable GENERIC: c-type ( name -- type ) foldable
: resolve-pointer-type ( name -- name ) : resolve-pointer-type ( name -- name )
@ -62,6 +63,60 @@ M: string c-type ( name -- type )
] ?if ] ?if
] 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 -- ) : c-type-box ( n type -- )
dup c-type-reg-class dup c-type-reg-class
swap c-type-boxer [ "No boxer" throw ] unless* 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* swap c-type-unboxer [ "No unboxer" throw ] unless*
%unbox ; %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 -- ) GENERIC: box-parameter ( n ctype -- )
M: c-type box-parameter c-type-box ; 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: 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 GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ; 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 GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ; M: byte-array byte-length length ;
: c-getter ( name -- quot ) : c-getter ( name -- quot )
c-type c-type-getter [ c-type-getter [
[ "Cannot read struct fields with type" throw ] [ "Cannot read struct fields with type" throw ]
] unless* ; ] unless* ;
: c-setter ( name -- quot ) : c-setter ( name -- quot )
c-type c-type-setter [ c-type-setter [
[ "Cannot write struct fields with type" throw ] [ "Cannot write struct fields with type" throw ]
] unless* ; ] unless* ;

View File

@ -1,5 +1,5 @@
IN: alien.structs 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 alien.syntax sequences io arrays slots.deprecated
kernel words slots assocs namespaces accessors ; 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 first dup "writing" word-prop [ slot-specs ] keep
$spec-writer ; $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 ; M: array ($instance) first ($instance) " array" write ;

View File

@ -7,7 +7,7 @@ C-STRUCT: bar
{ { "int" 8 } "y" } ; { { "int" 8 } "y" } ;
[ 36 ] [ "bar" heap-size ] unit-test [ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test [ t ] [ \ <displaced-alien> "bar" c-type-getter memq? ] unit-test
C-STRUCT: align-test C-STRUCT: align-test
{ "int" "x" } { "int" "x" }

View File

@ -6,7 +6,7 @@ slots.deprecated alien.c-types cpu.architecture ;
IN: alien.structs IN: alien.structs
: align-offset ( offset type -- offset ) : align-offset ( offset type -- offset )
c-type c-type-align align ; c-type-align align ;
: struct-offsets ( specs -- size ) : struct-offsets ( specs -- size )
0 [ 0 [
@ -24,7 +24,7 @@ IN: alien.structs
[ reader>> ] [ reader>> ]
[ [
class>> class>>
[ c-getter ] [ c-type c-type-boxer-quot ] bi append [ c-getter ] [ c-type-boxer-quot ] bi append
] tri ] tri
define-struct-slot-word ; define-struct-slot-word ;
@ -44,9 +44,9 @@ IN: alien.structs
TUPLE: struct-type size align fields ; 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 ; M: struct-type c-type-stack-align? drop f ;

View File

@ -1,11 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units definitions assocs compiler.errors compiler.units
math.parser generic sets ; math.parser generic sets debugger command-line ;
IN: bootstrap.stage2 IN: bootstrap.stage2
SYMBOL: bootstrap-time SYMBOL: bootstrap-time

View File

@ -69,23 +69,21 @@ TUPLE: ds-loc n class ;
: <ds-loc> ( n -- loc ) f ds-loc boa ; : <ds-loc> ( n -- loc ) f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ; M: ds-loc minimal-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 live-loc? 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. ! A retain stack location.
TUPLE: rs-loc n class ; TUPLE: rs-loc n class ;
: <rs-loc> ( n -- loc ) f rs-loc boa ; : <rs-loc> ( 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? 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 ; UNION: loc ds-loc rs-loc ;
M: loc operand-class* class>> ;
M: loc set-operand-class (>>class) ;
M: loc move-spec drop loc ; M: loc move-spec drop loc ;
INSTANCE: loc value 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 operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ; M: cached move-spec drop cached ;
M: cached live-vregs* vreg>> live-vregs* ; 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-load) >r vreg>> r> (lazy-load) ;
M: cached lazy-store M: cached lazy-store
2dup cached-loc live-loc? 2dup loc>> live-loc?
[ "live-locs" get at %move ] [ 2drop ] if ; [ "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 INSTANCE: cached value
@ -121,48 +119,48 @@ TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged ) : <tagged> ( vreg -- tagged )
f tagged boa ; f tagged boa ;
M: tagged v>operand tagged-vreg v>operand ; M: tagged v>operand vreg>> v>operand ;
M: tagged set-operand-class set-tagged-class ; M: tagged set-operand-class (>>class) ;
M: tagged operand-class* tagged-class ; M: tagged operand-class* class>> ;
M: tagged move-spec drop f ; M: tagged move-spec drop f ;
M: tagged live-vregs* tagged-vreg , ; M: tagged live-vregs* vreg>> , ;
INSTANCE: tagged value INSTANCE: tagged value
! Unboxed alien pointers ! Unboxed alien pointers
TUPLE: unboxed-alien vreg ; TUPLE: unboxed-alien vreg ;
C: <unboxed-alien> unboxed-alien C: <unboxed-alien> 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 operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ; M: unboxed-alien move-spec class ;
M: unboxed-alien live-vregs* unboxed-alien-vreg , ; M: unboxed-alien live-vregs* vreg>> , ;
INSTANCE: unboxed-alien value INSTANCE: unboxed-alien value
TUPLE: unboxed-byte-array vreg ; TUPLE: unboxed-byte-array vreg ;
C: <unboxed-byte-array> unboxed-byte-array C: <unboxed-byte-array> 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 operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ; 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 INSTANCE: unboxed-byte-array value
TUPLE: unboxed-f vreg ; TUPLE: unboxed-f vreg ;
C: <unboxed-f> unboxed-f C: <unboxed-f> 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 operand-class* drop \ f ;
M: unboxed-f move-spec class ; M: unboxed-f move-spec class ;
M: unboxed-f live-vregs* unboxed-f-vreg , ; M: unboxed-f live-vregs* vreg>> , ;
INSTANCE: unboxed-f value INSTANCE: unboxed-f value
TUPLE: unboxed-c-ptr vreg ; TUPLE: unboxed-c-ptr vreg ;
C: <unboxed-c-ptr> unboxed-c-ptr C: <unboxed-c-ptr> 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 operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ; 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 INSTANCE: unboxed-c-ptr value

View File

@ -1,10 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cpu.ppc.assembler cpu.architecture generic USING: accessors alien.c-types cpu.ppc.assembler
kernel kernel.private math memory namespaces sequences words cpu.architecture generic kernel kernel.private math memory
assocs compiler.generator compiler.generator.registers namespaces sequences words assocs compiler.generator
compiler.generator.fixup system layouts classes words.private compiler.generator.registers compiler.generator.fixup system
alien combinators compiler.constants math.order ; layouts classes words.private alien combinators
compiler.constants math.order ;
IN: cpu.ppc.architecture IN: cpu.ppc.architecture
! PowerPC register assignments ! 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 ) GENERIC: loc>operand ( loc -- reg n )
M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ; M: ds-loc loc>operand n>> cells neg ds-reg swap ;
M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ; M: rs-loc loc>operand n>> cells neg rs-reg swap ;
M: immediate load-literal M: immediate load-literal
[ v>operand ] bi@ LOAD ; [ v>operand ] bi@ LOAD ;

View File

@ -1,14 +1,15 @@
USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
namespaces alien.c-types kernel system combinators ; cpu.architecture namespaces alien.c-types kernel system
combinators ;
{ {
{ [ os macosx? ] [ { [ os macosx? ] [
4 "longlong" c-type set-c-type-align 4 "longlong" c-type (>>align)
4 "ulonglong" c-type set-c-type-align 4 "ulonglong" c-type (>>align)
4 "double" c-type set-c-type-align 4 "double" c-type (>>align)
] } ] }
{ [ os linux? ] [ { [ os linux? ] [
t "longlong" c-type set-c-type-stack-align? t "longlong" c-type (>>stack-align?)
t "ulonglong" c-type set-c-type-stack-align? t "ulonglong" c-type (>>stack-align?)
] } ] }
} cond } cond

View File

@ -259,9 +259,9 @@ M: x86.32 %cleanup ( alien-node -- )
M: x86.32 %unwind ( n -- ) %epilogue-later RET ; M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
os windows? [ os windows? [
cell "longlong" c-type set-c-type-align cell "longlong" c-type (>>align)
cell "ulonglong" c-type set-c-type-align cell "ulonglong" c-type (>>align)
4 "double" c-type set-c-type-align 4 "double" c-type (>>align)
] unless ] unless
: (sse2?) ( -- ? ) "Intrinsic" throw ; : (sse2?) ( -- ? ) "Intrinsic" throw ;

View File

@ -174,10 +174,10 @@ USE: cpu.x86.intrinsics
! The ABI for passing structs by value is pretty messed up ! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type << "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-types&offset ( struct-type -- pairs )
struct-type-fields [ fields>> [
[ class>> ] [ offset>> ] bi 2array [ class>> ] [ offset>> ] bi 2array
] map ; ] map ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 cpu.x86.assembler.private cpu.architecture kernel kernel.private
math memory namespaces sequences words compiler.generator math memory namespaces sequences words compiler.generator
compiler.generator.registers compiler.generator.fixup system 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 [+] ; : reg-stack ( n reg -- op ) swap cells neg [+] ;
M: ds-loc v>operand ds-loc-n ds-reg reg-stack ; M: ds-loc v>operand n>> ds-reg reg-stack ;
M: rs-loc v>operand rs-loc-n rs-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 %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ; M: int-regs %load-param-reg drop swap stack@ MOV ;

View File

@ -207,7 +207,7 @@ M: no-case summary
M: slice-error error. M: slice-error error.
"Cannot create slice because " write "Cannot create slice because " write
slice-error-reason print ; reason>> print ;
M: bounds-error summary drop "Sequence index out of bounds" ; 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. M: redefine-error error.
"Re-definition of " write "Re-definition of " write
redefine-error-def . ; def>> . ;
M: undefined summary M: undefined summary
drop "Calling a deferred word before it has been defined" ; drop "Calling a deferred word before it has been defined" ;
M: no-compilation-unit error. M: no-compilation-unit error.
"Attempting to define " write "Attempting to define " write
no-compilation-unit-definition pprint definition>> pprint
" outside of a compilation unit" print ; " outside of a compilation unit" print ;
M: no-vocab summary M: no-vocab summary
@ -299,9 +299,9 @@ M: string expected>string ;
M: unexpected error. M: unexpected error.
"Expected " write "Expected " write
dup unexpected-want expected>string write dup want>> expected>string write
" but got " write " but got " write
unexpected-got expected>string print ; got>> expected>string print ;
M: lexer-error error. M: lexer-error error.
[ lexer-dump ] [ error>> error. ] bi ; [ lexer-dump ] [ error>> error. ] bi ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; prettyprint.backend prettyprint words kernel effects ;
IN: help.definitions IN: help.definitions
@ -8,30 +8,30 @@ IN: help.definitions
M: link definer drop \ ARTICLE: \ ; ; 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 definition article-content ;
M: link synopsis* M: link synopsis*
dup definer. dup definer.
dup link-name pprint* dup name>> pprint*
article-title pprint* ; article-title pprint* ;
M: word-link definer drop \ HELP: \ ; ; 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* M: word-link synopsis*
dup definer. dup definer.
link-name dup pprint-word name>> dup pprint-word
stack-effect. ; stack-effect. ;
M: word-link forget* link-name remove-word-help ; M: word-link forget* name>> remove-word-help ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel parser sequences words help help.topics USING: accessors arrays kernel parser sequences words help
namespaces vocabs definitions compiler.units ; help.topics namespaces vocabs definitions compiler.units ;
IN: help.syntax IN: help.syntax
: HELP: : HELP:
@ -16,7 +16,6 @@ IN: help.syntax
over add-article >link r> remember-definition ; parsing over add-article >link r> remember-definition ; parsing
: ABOUT: : ABOUT:
scan-object
in get vocab in get vocab
dup changed-definition dup changed-definition
set-vocab-help ; parsing scan-object >>help drop ; parsing

View File

@ -34,6 +34,6 @@ SYMBOL: foo
] unit-test ] unit-test
[ { "testfile" 2 } ] [ { "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 [ ] [ { "test" 1 } remove-article ] unit-test

View File

@ -34,6 +34,8 @@ SYMBOL: article-xref
article-xref global [ H{ } assoc-like ] change-at article-xref global [ H{ } assoc-like ] change-at
GENERIC: article-name ( topic -- string ) GENERIC: article-name ( topic -- string )
GENERIC: article-title ( topic -- string )
GENERIC: article-content ( topic -- content )
GENERIC: article-parent ( topic -- parent ) GENERIC: article-parent ( topic -- parent )
GENERIC: set-article-parent ( parent topic -- ) GENERIC: set-article-parent ( parent topic -- )
@ -42,7 +44,9 @@ TUPLE: article title content loc ;
: <article> ( title content -- article ) : <article> ( title content -- article )
f \ article boa ; 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 ; ERROR: no-article name ;

View File

@ -109,7 +109,7 @@ M: output-port stream-write1
M: output-port stream-write M: output-port stream-write
dup check-disposed dup check-disposed
over length over buffer>> buffer-size > [ over length over buffer>> size>> > [
[ buffer>> size>> <groups> ] [ buffer>> size>> <groups> ]
[ [ stream-write ] curry ] bi [ [ stream-write ] curry ] bi
each each

View File

@ -63,12 +63,7 @@ HELP: set-model
{ $values { "value" object } { "model" 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 } "." } ; { $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 { set-model 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." } ;
HELP: change-model HELP: change-model
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } } { $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } }

View File

@ -17,7 +17,7 @@ TUPLE: just-parser p1 ;
M: just-parser (compile) ( parser -- quot ) 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 -- parser )
just-parser boa wrap-peg ; just-parser boa wrap-peg ;

View File

@ -105,7 +105,7 @@ M: sbuf pprint*
dup "SBUF\" " "\"" pprint-string ; dup "SBUF\" " "\"" pprint-string ;
M: pathname pprint* M: pathname pprint*
dup pathname-string "P\" " "\"" pprint-string ; dup string>> "P\" " "\"" pprint-string ;
! Sequences ! Sequences
: nesting-limit? ( -- ? ) : nesting-limit? ( -- ? )

View File

@ -172,7 +172,7 @@ M: hook-generic synopsis*
[ definer. ] [ definer. ]
[ seeing-word ] [ seeing-word ]
[ pprint-word ] [ pprint-word ]
[ "combination" word-prop hook-combination-var pprint* ] [ "combination" word-prop var>> pprint* ]
[ stack-effect. ] [ stack-effect. ]
} cleave ; } cleave ;

View File

@ -205,7 +205,7 @@ TUPLE: text < section string ;
swap >>style swap >>style
swap >>string ; swap >>string ;
M: text short-section text-string write ; M: text short-section string>> write ;
M: text long-section short-section ; M: text long-section short-section ;
@ -291,17 +291,13 @@ SYMBOL: next
: split-groups ( ? -- ) [ t , ] when ; : split-groups ( ? -- ) [ t , ] when ;
M: f section-start-group? drop t ;
M: f section-end-group? drop f ;
: split-before ( section -- ) : 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 ] [ flow? prev get flow? not and ]
bi or split-groups ; bi or split-groups ;
: split-after ( section -- ) : split-after ( section -- )
section-end-group? split-groups ; [ end-group?>> ] [ f ] if* split-groups ;
: group-flow ( seq -- newseq ) : group-flow ( seq -- newseq )
[ [

View File

@ -181,12 +181,12 @@ M: vocab-spec article-parent drop "vocab-index" ;
M: vocab-tag >link ; M: vocab-tag >link ;
M: vocab-tag article-title 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 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" ; 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 >link ;
M: vocab-author article-title 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 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" ; M: vocab-author article-parent drop "vocab-index" ;

View File

@ -210,7 +210,7 @@ M: enum at*
M: enum set-at seq>> set-nth ; 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 ) M: enum >alist ( enum -- alist )
seq>> [ length ] keep zip ; seq>> [ length ] keep zip ;

View File

@ -78,8 +78,8 @@ TUPLE: mixin-instance loc class mixin ;
M: mixin-instance equal? M: mixin-instance equal?
{ {
{ [ over mixin-instance? not ] [ f ] } { [ over mixin-instance? not ] [ f ] }
{ [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } { [ 2dup [ class>> ] bi@ = not ] [ f ] }
{ [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } { [ 2dup [ mixin>> ] bi@ = not ] [ f ] }
[ t ] [ t ]
} cond 2nip ; } cond 2nip ;
@ -91,15 +91,14 @@ M: mixin-instance hashcode*
swap >>mixin swap >>mixin
swap >>class ; 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 definer drop \ INSTANCE: f ;
M: mixin-instance definition drop f ; M: mixin-instance definition drop f ;
M: mixin-instance forget* M: mixin-instance forget*
dup mixin-instance-class [ class>> ] [ mixin>> ] bi
swap mixin-instance-mixin dup mixin-class? mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;
[ remove-mixin-instance ] [ 2drop ] if ;

View File

@ -178,7 +178,7 @@ M: condition compute-restarts
[ error>> compute-restarts ] [ error>> compute-restarts ]
[ [
[ restarts>> ] [ restarts>> ]
[ condition-continuation [ <restart> ] curry ] bi [ continuation>> [ <restart> ] curry ] bi
{ } assoc>map { } assoc>map
] bi append ; ] bi append ;

View File

@ -130,9 +130,9 @@ M: encoder stream-write1
M: encoder stream-write M: encoder stream-write
>encoder< decoder-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 INSTANCE: encoder plain-writer
PRIVATE> PRIVATE>

View File

@ -56,7 +56,7 @@ ERROR: invalid-source-file-path path ;
] [ 2drop ] if ] [ 2drop ] if
] assoc-each ; ] assoc-each ;
M: pathname where pathname-string 1 2array ; M: pathname where string>> 1 2array ;
: forget-source ( path -- ) : forget-source ( path -- )
[ [
@ -69,7 +69,7 @@ M: pathname where pathname-string 1 2array ;
bi ; bi ;
M: pathname forget* M: pathname forget*
pathname-string forget-source ; string>> forget-source ;
: rollback-source-file ( file -- ) : rollback-source-file ( file -- )
[ [

View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 definitions generic hashtables kernel math namespaces parser
lexer sequences strings strings.parser sbufs vectors lexer sequences strings strings.parser sbufs vectors
words quotations io assocs splitting classes.tuple words quotations io assocs splitting classes.tuple
@ -193,7 +193,7 @@ IN: bootstrap.syntax
"))" parse-effect parsed "))" parse-effect parsed
] define-syntax ] define-syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax "MAIN:" [ scan-word in get vocab (>>main) ] define-syntax
"<<" [ "<<" [
[ [

View File

@ -16,44 +16,78 @@ source-loaded? docs-loaded? ;
swap >>name swap >>name
H{ } clone >>words ; H{ } clone >>words ;
GENERIC: vocab-name ( vocab-spec -- name )
GENERIC: vocab ( vocab-spec -- vocab ) GENERIC: vocab ( vocab-spec -- vocab )
M: vocab vocab ; M: vocab vocab ;
M: object vocab ( name -- vocab ) vocab-name dictionary get at ; M: object vocab ( name -- vocab ) vocab-name dictionary get at ;
M: vocab vocab-name name>> ;
M: string vocab-name ; M: string vocab-name ;
GENERIC: vocab-words ( vocab-spec -- words )
M: vocab vocab-words words>> ;
M: object vocab-words vocab vocab-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: 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: 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? M: object vocab-source-loaded?
vocab 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? M: object set-vocab-source-loaded?
vocab 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? M: object vocab-docs-loaded?
vocab 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? M: object set-vocab-docs-loaded?
vocab 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 set-vocab-docs-loaded? 2drop ;
M: f vocab-help ;
: create-vocab ( name -- vocab ) : create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ; dictionary get [ <vocab> ] cache ;
@ -90,10 +124,9 @@ TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link ) : <vocab-link> ( name -- vocab-link )
vocab-link boa ; vocab-link boa ;
M: vocab-link hashcode* M: vocab-link hashcode* name>> hashcode* ;
vocab-link-name hashcode* ;
M: vocab-link vocab-name vocab-link-name ; M: vocab-link vocab-name name>> ;
UNION: vocab-spec vocab vocab-link ; UNION: vocab-spec vocab vocab-link ;