diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 07f02491c6..cb60d8768e 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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 diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 1155eef6cf..db2dde658f 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -70,7 +70,7 @@ IN: bootstrap.syntax ">>" "call-next-method" "initial:" - "read-only:" + "read-only" } [ "syntax" create drop ] each "t" "syntax" lookup define-symbol diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 26ba594dca..acbbc5e841 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -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 diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index b54c1501fb..d75a63dfde 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -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 diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index a5282ce7d3..bab2b0f53d 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -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" - 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 [ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test -[ - "IN: classes.tuple.tests SYMBOL: not-a-class C: not-a-class" eval -] [ error>> not-a-tuple-class? ] must-fail-with - ! Inheritance TUPLE: computer cpu ram ; C: 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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 1329090bf5..41e139f4c3 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 - : tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; -: slots>tuple ( tuple class -- array ) - tuple-layout [ - [ 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 ; + +M: tuple-class boa + [ "boa-check" word-prop call ] + [ tuple-layout ] + bi ; + ! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index f532cd8a28..0e04042bea 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -28,9 +28,10 @@ IN: combinators ! spread : spread>quot ( seq -- quot ) - [ length [ >r ] concat ] - [ [ [ r> ] prepend ] map concat ] bi - append [ ] like ; + [ ] [ + [ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip + append + ] reduce ; : spread ( objs... seq -- ) spread>quot call ; diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 8d537f66c4..5d1825872a 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -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 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 diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index feb79a94d1..3bbb017570 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -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" ; diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor index cc307bd387..332fd2635a 100644 --- a/core/grouping/grouping.factor +++ b/core/grouping/grouping.factor @@ -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 diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 6f0601354a..78860ab895 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -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 [ ] curry + [ "boa-check" word-prop ] + [ tuple-layout [ ] curry ] + bi append ] [ - [ not-a-tuple-class ] curry time-bomb + \ boa \ no-method boa time-bomb ] if ] 1 define-transform +: [tuple-boa] ( layout -- quot ) + [ [ ] curry ] + [ + size>> 1 - [ 3 + ] map + [ [ set-slot ] curry [ keep ] curry ] map concat + ] + bi append ; + +\ [ [tuple-boa] ] 1 define-transform + \ (call-next-method) [ [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi ] 2 define-transform diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index aa335aed90..023ded5e9c 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -142,11 +142,9 @@ M: object clone ; M: callstack clone (clone) ; ! Tuple construction -: new ( class -- tuple ) - tuple-layout ; +GENERIC: new ( class -- tuple ) -: boa ( ... class -- tuple ) - tuple-layout ; +GENERIC: boa ( ... class -- tuple ) ! Quotation building : 2curry ( obj1 obj2 quot -- curry ) diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 7d05196007..e78d4104a1 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -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 @@ -13,26 +14,27 @@ C: interval : closed-point ( n -- endpoint ) t 2array ; : [a,b] ( a b -- interval ) - >r closed-point r> closed-point ; + >r closed-point r> closed-point ; foldable : (a,b) ( a b -- interval ) - >r open-point r> open-point ; + >r open-point r> open-point ; foldable : [a,b) ( a b -- interval ) - >r closed-point r> open-point ; + >r closed-point r> open-point ; foldable : (a,b] ( a b -- interval ) - >r open-point r> closed-point ; + >r open-point r> closed-point ; foldable -: [a,a] ( a -- interval ) closed-point dup ; +: [a,a] ( a -- interval ) + closed-point dup ; 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 : 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 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 [ [ 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] ; diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 939cb817c2..9e2ea71a3e 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -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 } ; : ( 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 diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 16d4097416..1ea93080e9 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 @@ -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 diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 32b3bc2ecb..892cb6b707 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -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 diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 61cec47c94..c1d2a5cf9b 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -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 diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 86f9cba9fe..9544e66088 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -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 ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index c0bca99320..9408c36f9a 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -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" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 5257fb5e55..bfb68b8b44 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -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 diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor index 955d1b2596..9c205a6bc8 100755 --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -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 } ; : ( a b step -- range ) >r over - r>