steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/arrays/arrays.factor
View File

@ -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 ;

67
basis/alien/c-types/c-types.factor
View File

@ -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* ;

4
basis/alien/structs/structs-docs.factor
View File

@ -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 ;

2
basis/alien/structs/structs-tests.factor
View File

@ -7,7 +7,7 @@ C-STRUCT: bar
{ { "int" 8 } "y" } ;
[ 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
{ "int" "x" }

8
basis/alien/structs/structs.factor
View File

@ -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 ;

4
basis/bootstrap/stage2.factor
View File

@ -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

42
basis/compiler/generator/registers/registers.factor
View File

@ -69,23 +69,21 @@ TUPLE: ds-loc n class ;
: <ds-loc> ( 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 ;
: <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?
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 ;
: <tagged> ( 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> 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> 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> 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> 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

15
basis/cpu/ppc/architecture/architecture.factor
View File

@ -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 ;

15
basis/cpu/ppc/ppc.factor
View File

@ -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

6
basis/cpu/x86/32/32.factor
View File

@ -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 ;

4
basis/cpu/x86/64/64.factor
View File

@ -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 ;

6
basis/cpu/x86/architecture/architecture.factor
View File

@ -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 ;

10
basis/debugger/debugger.factor
View File

@ -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 ;

22
basis/help/definitions/definitions.factor
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.
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 ;

7
basis/help/syntax/syntax.factor
View File

@ -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

2
basis/help/topics/topics-tests.factor
View File

@ -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

6
basis/help/topics/topics.factor
View File

@ -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 ;
: <article> ( 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 ;

2
basis/io/ports/ports.factor
View File

@ -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>> <groups> ]
[ [ stream-write ] curry ] bi
each

7
basis/models/models-docs.factor
View File

@ -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 )" } } }

2
basis/peg/parsers/parsers.factor
View File

@ -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 ;

2
basis/prettyprint/backend/backend.factor
View File

@ -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? ( -- ? )

2
basis/prettyprint/prettyprint.factor
View File

@ -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 ;

10
basis/prettyprint/sections/sections.factor
View File

@ -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 )
[

12
basis/tools/vocabs/browser/browser.factor
View File

@ -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" ;

2
core/assocs/assocs.factor
View File

@ -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 ;

13
core/classes/mixin/mixin.factor
View File

@ -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 ;

2
core/continuations/continuations.factor
View File

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

4
core/io/encodings/encodings.factor
View File

@ -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>

4
core/source-files/source-files.factor
View File

@ -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 -- )
[

4
core/syntax/syntax.factor
View File

@ -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
"<<" [
[

59
core/vocabs/vocabs.factor
View File

@ -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 [ <vocab> ] cache ;
@ -90,10 +124,9 @@ TUPLE: vocab-link name ;
: <vocab-link> ( 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 ;