Removing old accessor usages from core and basis
parent
ca5caafefe
commit
0c304b8fc6
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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* ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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" }
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )" } } }
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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? ( -- ? )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 )
|
||||||
[
|
[
|
||||||
|
|
|
@ -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" ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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>
|
||||||
|
|
|
@ -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 -- )
|
||||||
[
|
[
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
"<<" [
|
"<<" [
|
||||||
[
|
[
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue