BOA constructors now check types

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 }
+    { "numerator" { "integer" "math" } read-only }
-    { "denominator" { "integer" "math" } read-only: t }
+    { "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 }
+    { "real" { "real" "math" } read-only }
-    { "imaginary" { "real" "math" } read-only: t }
+    { "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 }
+    { "array" { "array" "arrays" } read-only }
-    { "compiled" read-only: t }
+    { "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 }
+    { "underlying" { "c-ptr" "alien" } read-only }
-    { "expired?" read-only: t }
+    { "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 }
+    { "hashcode" { "fixnum" "math" } read-only }
-    { "class" { "word" "words" } initial: t read-only: t }
+    { "class" { "word" "words" } initial: t read-only }
-    { "size" { "fixnum" "math" } read-only: t }
+    { "size" { "fixnum" "math" } read-only }
-    { "superclasses" { "array" "arrays" } initial: { } read-only: t }
+    { "superclasses" { "array" "arrays" } initial: { } read-only }
-    { "echelon" { "fixnum" "math" } read-only: t }
+    { "echelon" { "fixnum" "math" } read-only }
 } define-builtin
 
 "tuple" "kernel" create {
@@ -312,8 +312,8 @@ tuple
 "curry" "kernel" create
 tuple
 {
-    { "obj" read-only: t }
+    { "obj" read-only }
-    { "quot" read-only: t }
+    { "quot" read-only }
 } prepare-slots define-tuple-class
 
 "curry" "kernel" lookup
@@ -325,8 +325,8 @@ tuple
 "compose" "kernel" create
 tuple
 {
-    { "first" read-only: t }
+    { "first" read-only }
-    { "second" read-only: t }
+    { "second" read-only }
 } prepare-slots define-tuple-class
 
 "compose" "kernel" lookup

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

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

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
 

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

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
-
 <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 )
+: all-slots ( class -- slots )
-    tuple-layout <tuple> [
+    superclasses [ "slots" word-prop ] map concat ;
-        [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
+
+: 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 -- ? )
+: tuple-instance? ( object class echelon -- ? )
-    over tuple? [
+    #! 4 slot == superclasses>>
-        [
+    rot dup tuple? [
-            [ layout-of superclasses>> ]
+        layout-of 4 slot
-            [ tuple-layout echelon>> ] bi*
+        2dup array-capacity fixnum<
-            swap ?nth
+        [ array-nth eq? ] [ 3drop f ] if
-        ] keep eq?
+    ] [ 3drop f ] if ; inline
-    ] [ 2drop 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-layout ]
-    [ define-tuple-predicate ]
+        [ define-tuple-slots ]
-    tri ;
+        [ 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 ;

core/combinators/combinators.factor

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

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

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.
+M: bad-slot-value summary drop "Bad store to specialized slot" ;
-    "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: 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" ;
 

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
 

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
+USING: accessors arrays kernel words sequences generic math
-quotations assocs combinators math.bitfields inference.backend
+namespaces quotations assocs combinators math.bitfields
-inference.dataflow inference.state classes.tuple
+inference.backend inference.dataflow inference.state
-classes.tuple.private effects inspector hashtables classes
+classes.tuple classes.tuple.private effects inspector hashtables
-generic sets definitions ;
+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

core/kernel/kernel.factor

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

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> 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
+        [ [ from>> ] [ from>> ] [ ] tri* (interval-op) ]
-    pick interval-to pick interval-to pick (interval-op) >r
+        [ [ to>>   ] [ from>> ] [ ] tri* (interval-op) ]
-    pick interval-from pick interval-to pick (interval-op) >r
+        [ [ to>>   ] [ to>>   ] [ ] tri* (interval-op) ]
-    3drop r> r> r> r> 4array points>interval ; inline
+        [ [ 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
+    [ from>> first2 [ 1+ ] unless ]
-    swap interval-to first2 [ 1- ] unless
+    [ to>> first2 [ 1- ] unless ]
-    [a,b] ;
+    bi [a,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 )
+TUPLE: mirror { object read-only } { slots read-only } ;
-    superclasses [ "slots" word-prop ] map concat ;
-
-: object-slots ( obj -- seq )
-    class all-slots ;
-
-TUPLE: mirror object slots ;
 
 : <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
 

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> reversed
 
@@ -177,9 +177,9 @@ INSTANCE: reversed virtual-sequence
 
 ! A slice of another sequence.
 TUPLE: slice
-{ from read-only: t }
+{ from read-only }
-{ to read-only: t }
+{ to read-only }
-{ seq read-only: t } ;
+{ 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
 

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:"
+"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."
-{ $list
+$nl
-    { "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." }
+"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."
-    { "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." }
+$nl
-}
+"In addition, two utility words are defined for each writable slot."
-"In addition, two utility words are defined for each distinct slot name used in the system:"
+$nl
-{ $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 "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 )" } "." }
+"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

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

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 %
+        dup class>> "predicate" word-prop %
-        [ [ set-slot ] [ bad-slot-value ] if ] %
+        [ 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 ;

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:
+HELP: read-only
-{ $syntax "TUPLE: ... { \"slot\" read-only: ? } ... ;" }
+{ $syntax "TUPLE: ... { \"slot\" read-only } ... ;" }
-{ $values { "slot" "a slot name" } { "?" "a boolean" } }
+{ $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" }

core/syntax/syntax.factor

@@ -172,8 +172,7 @@ IN: bootstrap.syntax
 
     "C:" [
         CREATE-WORD
-        scan-word check-tuple-class
+        scan-word [ boa ] curry define-inline
-        [ 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

extra/math/ranges/ranges.factor

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