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

BOA constructors now check types

db4
Slava Pestov 2008-06-30 01:44:58 -05:00
parent a91d51dc1c
commit f7b7001f39
21 changed files with 229 additions and 184 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
core/bootstrap/primitives.factor
View File

@ -217,42 +217,42 @@ bi
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
"ratio" "math" create {
{ "numerator" { "integer" "math" } read-only: t }
{ "denominator" { "integer" "math" } read-only: t }
{ "numerator" { "integer" "math" } read-only }
{ "denominator" { "integer" "math" } read-only }
} define-builtin
"float" "math" create { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
"complex" "math" create {
{ "real" { "real" "math" } read-only: t }
{ "imaginary" { "real" "math" } read-only: t }
{ "real" { "real" "math" } read-only }
{ "imaginary" { "real" "math" } read-only }
} define-builtin
"array" "arrays" create { } define-builtin
"wrapper" "kernel" create {
{ "wrapped" read-only: t }
{ "wrapped" read-only }
} define-builtin
"string" "strings" create {
{ "length" { "array-capacity" "sequences.private" } read-only: t }
{ "length" { "array-capacity" "sequences.private" } read-only }
"aux"
} define-builtin
"quotation" "quotations" create {
{ "array" { "array" "arrays" } read-only: t }
{ "compiled" read-only: t }
{ "array" { "array" "arrays" } read-only }
{ "compiled" read-only }
} define-builtin
"dll" "alien" create {
{ "path" { "byte-array" "byte-arrays" } read-only: t }
{ "path" { "byte-array" "byte-arrays" } read-only }
}
define-builtin
"alien" "alien" create {
{ "underlying" { "c-ptr" "alien" } read-only: t }
{ "expired?" read-only: t }
{ "underlying" { "c-ptr" "alien" } read-only }
{ "expired?" read-only }
}
define-builtin
@ -262,7 +262,7 @@ define-builtin
"vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] }
"props"
{ "compiled" read-only: t }
{ "compiled" read-only }
{ "counter" { "fixnum" "math" } }
} define-builtin
@ -275,11 +275,11 @@ define-builtin
"callstack" "kernel" create { } define-builtin
"tuple-layout" "classes.tuple.private" create {
{ "hashcode" { "fixnum" "math" } read-only: t }
{ "class" { "word" "words" } initial: t read-only: t }
{ "size" { "fixnum" "math" } read-only: t }
{ "superclasses" { "array" "arrays" } initial: { } read-only: t }
{ "echelon" { "fixnum" "math" } read-only: t }
{ "hashcode" { "fixnum" "math" } read-only }
{ "class" { "word" "words" } initial: t read-only }
{ "size" { "fixnum" "math" } read-only }
{ "superclasses" { "array" "arrays" } initial: { } read-only }
{ "echelon" { "fixnum" "math" } read-only }
} define-builtin
"tuple" "kernel" create {
@ -312,8 +312,8 @@ tuple
"curry" "kernel" create
tuple
{
{ "obj" read-only: t }
{ "quot" read-only: t }
{ "obj" read-only }
{ "quot" read-only }
} prepare-slots define-tuple-class
"curry" "kernel" lookup
@ -325,8 +325,8 @@ tuple
"compose" "kernel" create
tuple
{
{ "first" read-only: t }
{ "second" read-only: t }
{ "first" read-only }
{ "second" read-only }
} prepare-slots define-tuple-class
"compose" "kernel" lookup

2
core/bootstrap/syntax.factor
View File

@ -70,7 +70,7 @@ IN: bootstrap.syntax
">>"
"call-next-method"
"initial:"
"read-only:"
"read-only"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol

4
core/classes/builtin/builtin.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes words kernel kernel.private namespaces
sequences math ;
sequences math math.private ;
IN: classes.builtin
SYMBOL: builtins
@ -24,7 +24,7 @@ M: builtin-class rank-class drop 0 ;
: builtin-instance? ( object n -- ? )
#! 7 == tag-mask get
#! 3 == hi-tag tag-number
dup 7 <= [ swap tag eq? ] [
dup 7 fixnum<= [ swap tag eq? ] [
swap dup tag 3 eq?
[ hi-tag eq? ] [ 2drop f ] if
] if ; inline

2
core/classes/tuple/parser/parser-tests.factor
View File

@ -35,7 +35,7 @@ TUPLE: test-7 { b integer initial: 3 } ;
[ 3 ] [ "b" test-7 "slots" word-prop slot-named initial>> ] unit-test
TUPLE: test-8 { b integer read-only: t } ;
TUPLE: test-8 { b integer read-only } ;
[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test

53
core/classes/tuple/tuple-tests.factor
View File

@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector
columns math.order classes.private slots.private ;
columns math.order classes.private slots slots.private ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@ -190,15 +190,6 @@ M: vector silly "z" ;
! Typo
SYMBOL: not-a-tuple-class
[
"IN: classes.tuple.tests C: <not-a-tuple-class> not-a-tuple-class"
eval
] must-fail
[ t ] [
"not-a-tuple-class" "classes.tuple.tests" lookup symbol?
] unit-test
! Missing check
[ not-a-tuple-class boa ] must-fail
[ not-a-tuple-class new ] must-fail
@ -218,10 +209,6 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
[
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ error>> not-a-tuple-class? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
C: <computer> computer
@ -490,7 +477,7 @@ USE: vocabs
] with-compilation-unit
] unit-test
[ "USE: words T{ word }" eval ] [ error>> not-a-tuple-class? ] must-fail-with
[ "USE: words T{ word }" eval ] [ error>> T{ no-method f word new } = ] must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
@ -598,3 +585,39 @@ GENERIC: break-me ( obj -- )
! Insufficient type checking
[ \ vocab tuple>array drop ] must-fail
! Check type declarations
TUPLE: declared-types { n fixnum } { m string } ;
[ T{ declared-types f 0 "hi" } ]
[ { declared-types f 0 "hi" } >tuple ]
unit-test
[ { declared-types f "hi" 0 } >tuple ]
[ T{ bad-slot-value f "hi" fixnum } = ]
must-fail-with
[ T{ declared-types f 0 "hi" } ]
[ 0.0 "hi" declared-types boa ] unit-test
: foo ( a b -- c ) declared-types boa ;
\ foo must-infer
[ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
[ "hi" 0.0 declared-types boa ]
[ T{ no-method f "hi" >fixnum } = ]
must-fail-with
[ 0 { } declared-types boa ]
[ T{ bad-slot-value f { } string } = ]
must-fail-with
[ "hi" 0.0 foo ]
[ T{ no-method f "hi" >fixnum } = ]
must-fail-with
[ 0 { } foo ]
[ T{ bad-slot-value f { } string } = ]
must-fail-with

87
core/classes/tuple/tuple.factor
View File

@ -14,15 +14,10 @@ ERROR: not-a-tuple object ;
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
ERROR: not-a-tuple-class class ;
: check-tuple-class ( class -- class )
dup tuple-class? [ not-a-tuple-class ] unless ; inline
<PRIVATE
: tuple-layout ( class -- layout )
check-tuple-class "layout" word-prop ;
"layout" word-prop ;
: layout-of ( tuple -- layout )
1 slot { tuple-layout } declare ; inline
@ -46,12 +41,26 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( tuple class -- array )
tuple-layout <tuple> [
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
: check-slots ( seq class -- seq class )
[ ] [
2dup all-slots [
class>> 2dup instance?
[ 2drop ] [ bad-slot-value ] if
] 2each
] if-bootstrapping ; inline
: slots>tuple ( seq class -- tuple )
check-slots
new [
[ tuple-size ]
[ [ set-array-nth ] curry ]
bi 2each
] keep ;
: >tuple ( tuple -- seq )
: >tuple ( seq -- tuple )
unclip slots>tuple ;
: slot-names ( class -- seq )
@ -73,22 +82,43 @@ ERROR: bad-superclass class ;
2drop f
] if ; inline
: tuple-instance? ( object class -- ? )
over tuple? [
[
[ layout-of superclasses>> ]
[ tuple-layout echelon>> ] bi*
swap ?nth
] keep eq?
] [ 2drop f ] if ; inline
: tuple-instance? ( object class echelon -- ? )
#! 4 slot == superclasses>>
rot dup tuple? [
layout-of 4 slot
2dup array-capacity fixnum<
[ array-nth eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline
: define-tuple-predicate ( class -- )
dup [ tuple-instance? ] curry define-predicate ;
dup dup tuple-layout echelon>>
[ tuple-instance? ] 2curry define-predicate ;
: superclass-size ( class -- n )
superclasses but-last-slice
[ slot-names length ] map sum ;
: (instance-check-quot) ( class -- quot )
[
\ dup ,
[ "predicate" word-prop % ]
[ [ bad-slot-value ] curry , ] bi
\ unless ,
] [ ] make ;
: instance-check-quot ( class -- quot )
{
{ [ dup object bootstrap-word eq? ] [ drop [ ] ] }
{ [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
[ (instance-check-quot) ]
} cond ;
: boa-check-quot ( class -- quot )
all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ;
: define-boa-check ( class -- )
dup boa-check-quot "boa-check" set-word-prop ;
: generate-tuple-slots ( class slots -- slot-specs )
over superclass-size 2 + make-slots deprecated-slots ;
@ -138,10 +168,12 @@ ERROR: bad-superclass class ;
outdated-tuples get [ all-slot-names ] cache drop ;
M: tuple-class update-class
[ define-tuple-layout ]
[ define-tuple-slots ]
[ define-tuple-predicate ]
tri ;
{
[ define-tuple-layout ]
[ define-tuple-slots ]
[ define-tuple-predicate ]
[ define-boa-check ]
} cleave ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f f tuple-class define-class ]
@ -210,7 +242,7 @@ M: tuple-class reset-class
M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
tuple-instance? ;
dup tuple-layout echelon>> tuple-instance? ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@ -226,6 +258,13 @@ M: tuple hashcode*
] 2curry each
] recursive-hashcode ;
M: tuple-class new tuple-layout <tuple> ;
M: tuple-class boa
[ "boa-check" word-prop call ]
[ tuple-layout ]
bi <tuple-boa> ;
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;

7
core/combinators/combinators.factor
View File

@ -28,9 +28,10 @@ IN: combinators
! spread
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
append [ ] like ;
[ ] [
[ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
append
] reduce ;
: spread ( objs... seq -- )
spread>quot call ;

8
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -63,6 +63,8 @@ IN: cpu.x86.intrinsics
: generate-write-barrier ( -- )
#! Mark the card pointed to by vreg.
"val" get operand-immediate? "obj" get fresh-object? or [
"obj" operand PUSH
! Mark the card
"obj" operand card-bits SHR
"cards_offset" f temp-reg v>operand %alien-global
@ -72,6 +74,8 @@ IN: cpu.x86.intrinsics
"obj" operand deck-bits card-bits - SHR
"decks_offset" f temp-reg v>operand %alien-global
temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
"obj" operand POP
] unless ;
\ set-slot {
@ -79,21 +83,19 @@ IN: cpu.x86.intrinsics
{
[ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] H{
{ +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +clobber+ { "obj" } }
}
}
! Slot number is literal
{
[ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
{ +clobber+ { "obj" } }
}
}
! Slot number in a register
{
[ %slot-any "val" operand MOV generate-write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
{ +clobber+ { "obj" "n" } }
{ +clobber+ { "n" } }
}
}
} define-intrinsics

30
core/debugger/debugger.factor
View File

@ -196,32 +196,7 @@ M: no-method error.
" class." print
"Dispatching on object: " write object>> short. ;
M: bad-slot-value error.
"Bad store to specialized slot" print
dup [ index>> 2 - ] [ object>> class all-slots ] bi nth
standard-table-style [
[
[ "Object" write ] with-cell
[ over object>> short. ] with-cell
] with-row
[
[ "Slot" write ] with-cell
[ dup name>> short. ] with-cell
] with-row
[
[ "Slot class" write ] with-cell
[ dup class>> short. ] with-cell
] with-row
[
[ "Value" write ] with-cell
[ over value>> short. ] with-cell
] with-row
[
[ "Value class" write ] with-cell
[ over value>> class short. ] with-cell
] with-row
] tabular-output
2drop ;
M: bad-slot-value summary drop "Bad store to specialized slot" ;
M: no-math-method summary
drop "No suitable arithmetic method" ;
@ -238,9 +213,6 @@ M: check-method summary
M: not-a-tuple summary
drop "Not a tuple" ;
M: not-a-tuple-class summary
drop "Not a tuple class" ;
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;

2
core/grouping/grouping.factor
View File

@ -4,7 +4,7 @@ USING: kernel math math.order strings arrays vectors sequences
accessors ;
IN: grouping
TUPLE: abstract-groups { seq read-only: t } { n read-only: t } ;
TUPLE: abstract-groups { seq read-only } { n read-only } ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline

26
core/inference/transforms/transforms.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple
classes.tuple.private effects inspector hashtables classes
generic sets definitions ;
USING: accessors arrays kernel words sequences generic math
namespaces quotations assocs combinators math.bitfields
inference.backend inference.dataflow inference.state
classes.tuple classes.tuple.private effects inspector hashtables
classes generic sets definitions generic.standard slots.private ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@ -86,12 +86,24 @@ M: duplicated-slots-error summary
\ boa [
dup tuple-class? [
dup +inlined+ depends-on
tuple-layout [ <tuple-boa> ] curry
[ "boa-check" word-prop ]
[ tuple-layout [ <tuple-boa> ] curry ]
bi append
] [
[ not-a-tuple-class ] curry time-bomb
\ boa \ no-method boa time-bomb
] if
] 1 define-transform
: [tuple-boa] ( layout -- quot )
[ [ <tuple> ] curry ]
[
size>> 1 - [ 3 + ] map <reversed>
[ [ set-slot ] curry [ keep ] curry ] map concat
]
bi append ;
\ <tuple-boa> [ [tuple-boa] ] 1 define-transform
\ (call-next-method) [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
] 2 define-transform

6
core/kernel/kernel.factor
View File

@ -142,11 +142,9 @@ M: object clone ;
M: callstack clone (clone) ;
! Tuple construction
: new ( class -- tuple )
tuple-layout <tuple> ;
GENERIC: new ( class -- tuple )
: boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
GENERIC: boa ( ... class -- tuple )
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )

63
core/math/intervals/intervals.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: kernel sequences arrays math combinators math.order ;
USING: accessors kernel sequences arrays math math.order
combinators ;
IN: math.intervals
TUPLE: interval from to ;
TUPLE: interval { from read-only } { to read-only } ;
C: <interval> interval
@ -13,26 +14,27 @@ C: <interval> interval
: closed-point ( n -- endpoint ) t 2array ;
: [a,b] ( a b -- interval )
>r closed-point r> closed-point <interval> ;
>r closed-point r> closed-point <interval> ; foldable
: (a,b) ( a b -- interval )
>r open-point r> open-point <interval> ;
>r open-point r> open-point <interval> ; foldable
: [a,b) ( a b -- interval )
>r closed-point r> open-point <interval> ;
>r closed-point r> open-point <interval> ; foldable
: (a,b] ( a b -- interval )
>r open-point r> closed-point <interval> ;
>r open-point r> closed-point <interval> ; foldable
: [a,a] ( a -- interval ) closed-point dup <interval> ;
: [a,a] ( a -- interval )
closed-point dup <interval> ; foldable
: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ;
: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline
: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ;
: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline
: [a,inf] ( a -- interval ) 1./0. [a,b] ;
: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline
: (a,inf] ( a -- interval ) 1./0. (a,b] ;
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
: compare-endpoints ( p1 p2 quot -- ? )
>r over first over first r> call [
@ -58,7 +60,7 @@ C: <interval> interval
: endpoint-max ( p1 p2 -- p3 ) [ endpoint> ] most ;
: interval>points ( int -- from to )
dup interval-from swap interval-to ;
[ from>> ] [ to>> ] bi ;
: points>interval ( seq -- interval )
dup first
@ -71,11 +73,12 @@ C: <interval> interval
r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 )
pick interval-from pick interval-from pick (interval-op) >r
pick interval-to pick interval-from pick (interval-op) >r
pick interval-to pick interval-to pick (interval-op) >r
pick interval-from pick interval-to pick (interval-op) >r
3drop r> r> r> r> 4array points>interval ; inline
{
[ [ from>> ] [ from>> ] [ ] tri* (interval-op) ]
[ [ to>> ] [ from>> ] [ ] tri* (interval-op) ]
[ [ to>> ] [ to>> ] [ ] tri* (interval-op) ]
[ [ from>> ] [ to>> ] [ ] tri* (interval-op) ]
} 3cleave 4array points>interval ; inline
: interval+ ( i1 i2 -- i3 ) [ + ] interval-op ;
@ -150,7 +153,7 @@ C: <interval> interval
[ [ shift ] interval-op ] interval-integer-op interval-closure ;
: interval-shift-safe ( i1 i2 -- i3 )
dup interval-to first 100 > [
dup to>> first 100 > [
2drop f
] [
interval-shift
@ -188,17 +191,17 @@ SYMBOL: incomparable
: left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ] 2keep
[ nip interval-singleton? ] 2keep
[ interval-from ] bi@ =
[ from>> ] bi@ =
and and ;
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ] 2keep
[ drop interval-singleton? ] 2keep
[ interval-to ] bi@ =
[ to>> ] bi@ =
and and ;
: (interval<) ( i1 i2 -- i1 i2 ? )
over interval-from over interval-from endpoint< ;
over from>> over from>> endpoint< ;
: interval< ( i1 i2 -- ? )
{
@ -209,10 +212,10 @@ SYMBOL: incomparable
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
>r interval-from r> interval-to = ;
>r from>> r> to>> = ;
: right-endpoint-<= ( i1 i2 -- ? )
>r interval-to r> interval-from = ;
>r to>> r> from>> = ;
: interval<= ( i1 i2 -- ? )
{
@ -228,18 +231,18 @@ SYMBOL: incomparable
swap interval<= ;
: assume< ( i1 i2 -- i3 )
interval-to first [-inf,a) interval-intersect ;
to>> first [-inf,a) interval-intersect ;
: assume<= ( i1 i2 -- i3 )
interval-to first [-inf,a] interval-intersect ;
to>> first [-inf,a] interval-intersect ;
: assume> ( i1 i2 -- i3 )
interval-from first (a,inf] interval-intersect ;
from>> first (a,inf] interval-intersect ;
: assume>= ( i1 i2 -- i3 )
interval-to first [a,inf] interval-intersect ;
to>> first [a,inf] interval-intersect ;
: integral-closure ( i1 -- i2 )
dup interval-from first2 [ 1+ ] unless
swap interval-to first2 [ 1- ] unless
[a,b] ;
[ from>> first2 [ 1+ ] unless ]
[ to>> first2 [ 1- ] unless ]
bi [a,b] ;

12
core/mirrors/mirrors.factor
View File

@ -5,16 +5,10 @@ arrays classes slots slots.private classes.tuple math vectors
quotations accessors combinators ;
IN: mirrors
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
: object-slots ( obj -- seq )
class all-slots ;
TUPLE: mirror object slots ;
TUPLE: mirror { object read-only } { slots read-only } ;
: <mirror> ( object -- mirror )
dup object-slots mirror boa ;
dup class all-slots mirror boa ;
M: mirror at*
[ nip object>> ] [ slots>> slot-named ] 2bi
@ -24,7 +18,7 @@ M: mirror at*
{
{ [ dup not ] [ "No such slot" throw ] }
{ [ dup read-only>> ] [ "Read only slot" throw ] }
{ [ 2dup class>> instance? not ] [ "Bad store to specialized slot" throw ] }
{ [ 2dup class>> instance? not ] [ class>> bad-slot-value ] }
[ offset>> ]
} cond ; inline

10
core/sequences/sequences.factor
View File

@ -161,7 +161,7 @@ M: virtual-sequence new-sequence virtual-seq new-sequence ;
INSTANCE: virtual-sequence sequence
! A reversal of an underlying sequence.
TUPLE: reversed { seq read-only: t } ;
TUPLE: reversed { seq read-only } ;
C: <reversed> reversed
@ -177,9 +177,9 @@ INSTANCE: reversed virtual-sequence
! A slice of another sequence.
TUPLE: slice
{ from read-only: t }
{ to read-only: t }
{ seq read-only: t } ;
{ from read-only }
{ to read-only }
{ seq read-only } ;
: collapse-slice ( m n slice -- m' n' seq )
[ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline
@ -219,7 +219,7 @@ M: slice length [ to>> ] [ from>> ] bi - ;
INSTANCE: slice virtual-sequence
! One element repeated many times
TUPLE: repetition { len read-only: t } { elt read-only: t } ;
TUPLE: repetition { len read-only } { elt read-only } ;
C: <repetition> repetition

22
core/slots/slots-docs.factor
View File

@ -5,16 +5,16 @@ slots.private classes strings math ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:"
{ $list
{ "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." }
{ "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." }
}
"In addition, two utility words are defined for each distinct slot name used in the system:"
{ $list
{ "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
{ "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
}
"For every tuple slot, a " { $emphasis "reader" } " method is defined in the " { $vocab-link "accessors" } " vocabulary. The reader is named " { $snippet { $emphasis "slot" } ">>" } " and given a tuple, pushes the slot value on the stack."
$nl
"Writable slots - that is, those not attributed " { $link read-only } " - also have a " { $emphasis "writer" } ". The writer is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } ". If the slot is specialized to a specific class, the writer checks that the value being written into the slot is an instance of that class first."
$nl
"In addition, two utility words are defined for each writable slot."
$nl
"The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "."
$nl
"The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "."
$nl
"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."
$nl
"In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:"
@ -96,7 +96,7 @@ $nl
{ { $snippet "offset" } " - an " { $link integer } " offset specifying where the slot value is stored inside instances of the relevant class. This is an implementation detail." }
{ { $snippet "class" } " - a " { $link class } " declaring the set of possible values for the slot." }
{ { $snippet "initial" } " - an initial value for the slot." }
{ { $snippet "read-only" } " - a boolean indicating whether the slot is read only, or can be written to." }
{ { $snippet "read-only" } " - a boolean indicating whether the slot is read only or not. Read only slots do not have a writer method associated with them." }
} } ;
HELP: define-typecheck

6
core/slots/slots-tests.factor
View File

@ -4,7 +4,7 @@ tools.test generic words parser ;
TUPLE: r/w-test foo ;
TUPLE: r/o-test { foo read-only: t } ;
TUPLE: r/o-test { foo read-only } ;
[ r/o-test new 123 >>foo ] [ no-method? ] must-fail-with
@ -25,12 +25,12 @@ TUPLE: hello length ;
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
! See if declarations are cleared on redefinition
[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only: t } ;" eval ] unit-test
[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test
[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only: f } ;" eval ] unit-test
[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test

10
core/slots/slots.factor
View File

@ -43,7 +43,7 @@ TUPLE: slot-spec name offset class initial read-only reader writer ;
: writer-word ( name -- word )
"(>>" swap ")" 3append (( value object -- )) create-accessor ;
ERROR: bad-slot-value value object index ;
ERROR: bad-slot-value value class ;
: writer-quot/object ( slot-spec -- )
offset>> , \ set-slot , ;
@ -57,8 +57,10 @@ ERROR: bad-slot-value value object index ;
[ offset>> , ]
[
\ pick ,
class>> "predicate" word-prop %
[ [ set-slot ] [ bad-slot-value ] if ] %
dup class>> "predicate" word-prop %
[ set-slot ] ,
class>> [ 2nip bad-slot-value ] curry [ ] like ,
\ if ,
]
bi ;
@ -158,7 +160,7 @@ ERROR: bad-slot-attribute key ;
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
{ read-only: [ [ first >>read-only ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
[ bad-slot-attribute ]
} case
] unless ;

10
core/syntax/syntax-docs.factor
View File

@ -558,7 +558,7 @@ $nl
{ { $snippet "{ \"name\" attributes... }" } " - a slot which can hold any object, with optional attributes" }
{ { $snippet "{ \"name\" class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
}
"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only: } "." }
"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } "." }
{ $examples
"A simple tuple class:"
{ $code "TUPLE: color red green blue ;" }
@ -573,12 +573,12 @@ HELP: initial:
{ $values { "slot" "a slot name" } { "value" "any literal" } }
{ $description "Specifies an initial value for a tuple slot." } ;
HELP: read-only:
{ $syntax "TUPLE: ... { \"slot\" read-only: ? } ... ;" }
{ $values { "slot" "a slot name" } { "?" "a boolean" } }
HELP: read-only
{ $syntax "TUPLE: ... { \"slot\" read-only } ... ;" }
{ $values { "slot" "a slot name" } }
{ $description "Defines a tuple slot to be read-only. If a tuple has read-only slots, instances of the tuple should only be created by calling " { $link boa } ", instead of " { $link new } ". Using " { $link boa } " is the only way to set the value of a read-only slot." } ;
{ initial: read-only: } related-words
{ initial: read-only } related-words
HELP: SLOT:
{ $syntax "SLOT: name" }

5
core/syntax/syntax.factor
View File

@ -172,8 +172,7 @@ IN: bootstrap.syntax
"C:" [
CREATE-WORD
scan-word check-tuple-class
[ boa ] curry define-inline
scan-word [ boa ] curry define-inline
] define-syntax
"ERROR:" [
@ -215,5 +214,5 @@ IN: bootstrap.syntax
"initial:" "syntax" lookup define-symbol
"read-only:" "syntax" lookup define-symbol
"read-only" "syntax" lookup define-symbol
] with-compilation-unit

6
extra/math/ranges/ranges.factor
View File

@ -3,9 +3,9 @@ sequences.private accessors ;
IN: math.ranges
TUPLE: range
{ from read-only: t }
{ length read-only: t }
{ step read-only: t } ;
{ from read-only }
{ length read-only }
{ step read-only } ;
: <range> ( a b step -- range )
>r over - r>