diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 7a8c8a02c4..07f02491c6 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -67,6 +67,7 @@ bootstrapping? on "classes.private" "classes.tuple" "classes.tuple.private" + "classes.predicate" "compiler.units" "continuations.private" "float-arrays" @@ -117,7 +118,7 @@ bootstrapping? on tri ; : prepare-slots ( slots -- slots' ) - [ [ dup array? [ first2 create ] when ] map ] map ; + [ [ dup pair? [ first2 create ] when ] map ] map ; : define-builtin-slots ( class slots -- ) prepare-slots 1 make-slots @@ -147,6 +148,9 @@ bootstrapping? on "byte-array" "byte-arrays" create register-builtin "tuple-layout" "classes.tuple.private" create register-builtin +! For predicate classes +"predicate-instance?" "classes.predicate" create drop + ! We need this before defining c-ptr below "f" "syntax" lookup { } define-builtin @@ -256,7 +260,7 @@ define-builtin { "hashcode" { "fixnum" "math" } } "name" "vocabulary" - { "def" { "quotation" "quotations" } } + { "def" { "quotation" "quotations" } initial: [ ] } "props" { "compiled" read-only: t } { "counter" { "fixnum" "math" } } @@ -272,9 +276,9 @@ define-builtin "tuple-layout" "classes.tuple.private" create { { "hashcode" { "fixnum" "math" } read-only: t } - { "class" { "word" "words" } read-only: t } + { "class" { "word" "words" } initial: t read-only: t } { "size" { "fixnum" "math" } read-only: t } - { "superclasses" { "array" "arrays" } read-only: t } + { "superclasses" { "array" "arrays" } initial: { } read-only: t } { "echelon" { "fixnum" "math" } read-only: t } } define-builtin diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index 5560454b3a..4fb51f133d 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -5,8 +5,8 @@ sequences.private growable byte-arrays ; IN: byte-vectors TUPLE: byte-vector -{ "underlying" byte-array } -{ "length" array-capacity } ; +{ underlying byte-array } +{ length array-capacity } ; > ] unit-test [ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test -TUPLE: test-7 { "b" integer initial: 3 } ; +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 } ; [ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test @@ -51,11 +51,11 @@ must-fail-with [ error>> unexpected-eof? ] must-fail-with -[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { \"slot\" alien } ;" eval ] +[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot alien } ;" eval ] [ error>> no-initial-value? ] must-fail-with -[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { \"slot\" array initial: 5 } ;" eval ] +[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ] [ error>> bad-initial-value? ] must-fail-with diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index a4bea6fed2..260730383b 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -24,6 +24,9 @@ M: invalid-slot-name summary drop "Invalid slot name" ; +: parse-long-slot-name ( -- ) + [ scan , \ } parse-until % ] { } make ; + : parse-slot-name ( string/f -- ? ) #! This isn't meant to enforce any kind of policy, just #! to check for mistakes of this form: @@ -35,7 +38,7 @@ M: invalid-slot-name summary { [ dup not ] [ unexpected-eof ] } { [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] } { [ dup ";" = ] [ drop f ] } - [ dup "{" = [ drop \ } parse-until >array ] when , t ] + [ dup "{" = [ drop parse-long-slot-name ] when , t ] } cond ; : parse-tuple-slots ( -- ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index b9ef634a9e..3aecd4825e 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -33,7 +33,7 @@ PREDICATE: method-spec < pair : specific-method ( class generic -- method/f ) tuck order min-class dup [ swap method ] [ 2drop f ] if ; -GENERIC: effective-method ( ... generic -- method ) +GENERIC: effective-method ( generic -- method ) : next-method-class ( class generic -- class/f ) order [ class<= ] with filter reverse dup length 1 = diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor index caf46e5480..cc307bd387 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 n ; +TUPLE: abstract-groups { seq read-only: t } { n read-only: t } ; : check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index e991be5ab3..3b794d1715 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -5,9 +5,9 @@ assocs math.private sequences sequences.private vectors grouping ; IN: hashtables TUPLE: hashtable -{ "count" array-capacity } -{ "deleted" array-capacity } -{ "array" array } ; +{ count array-capacity } +{ deleted array-capacity } +{ array array } ; fixnum } inlined? ] unit-test +[ t ] [ + [ { declared-fixnum } declare x>> drop ] + { slot } inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor index 07c189cea0..51d3cb319d 100755 --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -79,11 +79,11 @@ SYMBOL: +editable+ : summary. ( obj -- ) [ summary ] keep write-object nl ; : sorted-keys ( assoc -- alist ) - dup mirror? [ keys ] [ + dup hashtable? [ keys [ [ unparse-short ] keep ] { } map>assoc sort-keys values - ] if ; + ] [ keys ] if ; : describe* ( obj flags -- ) clone [ diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor index 3145ce8b9f..0a30392281 100755 --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -31,7 +31,7 @@ C: foo [ gensym [ "compiled" off ] bind ] must-fail TUPLE: declared-mirror-test -{ "a" integer initial: 0 } ; +{ a integer initial: 0 } ; [ 5 ] [ 3 declared-mirror-test boa [ @@ -43,9 +43,9 @@ TUPLE: declared-mirror-test [ 3 declared-mirror-test boa [ t "a" set ] bind ] must-fail TUPLE: color -{ "red" integer } -{ "green" integer } -{ "blue" integer } ; +{ red integer } +{ green integer } +{ blue integer } ; [ T{ color f 0 0 0 } ] [ 1 2 3 color boa [ clear-assoc ] keep diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index c2a59f639e..e741f2d171 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -54,11 +54,15 @@ DEFER: (flat-length) [ def>> (flat-length) ] with-scope ; ! Single dispatch method inlining optimization +! : dispatching-class ( node generic -- method/f ) +! tuck dispatch# over in-d>> ?nth 2dup node-literal? +! [ node-literal swap single-effective-method ] +! [ node-class swap specific-method ] +! if ; + : dispatching-class ( node generic -- method/f ) - tuck dispatch# over in-d>> ?nth 2dup node-literal? - [ node-literal swap single-effective-method ] - [ node-class swap specific-method ] - if ; + tuck dispatch# over in-d>> ?nth + node-class swap specific-method ; : inline-standard-method ( node generic -- node ) dupd dispatching-class dup diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 9e11611f5b..fd76b87dbb 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -101,11 +101,20 @@ unit-test ] keep = ] with-scope ; -: method-test +GENERIC: method-layout + +M: complex method-layout + "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + ; + +M: fixnum method-layout ; + +M: integer method-layout ; + +M: object method-layout ; + +[ { - "IN: prettyprint.tests" - "GENERIC: method-layout" - "" "USING: math prettyprint.tests ;" "M: complex method-layout" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" @@ -119,10 +128,10 @@ unit-test "" "USING: kernel prettyprint.tests ;" "M: object method-layout ;" - } ; - -[ t ] [ - "method-layout" method-test check-see + "" + } +] [ + [ \ method-layout see-methods ] with-string-writer "\n" split ] unit-test : retain-stack-test @@ -255,7 +264,16 @@ DEFER: parse-error-file "another-narrow-layout" another-narrow-test check-see ] unit-test -: class-see-test +IN: prettyprint.tests +TUPLE: class-see-layout ; + +IN: prettyprint.tests +GENERIC: class-see-layout ( x -- y ) + +USING: prettyprint.tests ; +M: class-see-layout class-see-layout ; + +[ { "IN: prettyprint.tests" "TUPLE: class-see-layout ;" @@ -263,12 +281,19 @@ DEFER: parse-error-file "IN: prettyprint.tests" "GENERIC: class-see-layout ( x -- y )" "" + } +] [ + [ \ class-see-layout see ] with-string-writer "\n" split +] unit-test + +[ + { "USING: prettyprint.tests ;" "M: class-see-layout class-see-layout ;" - } ; - -[ t ] [ - "class-see-layout" class-see-test check-see + "" + } +] [ + [ \ class-see-layout see-methods ] with-string-writer "\n" split ] unit-test [ ] [ \ effect-in synopsis drop ] unit-test diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 6006d9d19f..f15106d78b 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -268,13 +268,22 @@ M: predicate-class see-class* M: singleton-class see-class* ( class -- ) \ SINGLETON: pprint-word pprint-word ; +GENERIC: pprint-slot-name ( object -- ) + +M: string pprint-slot-name text ; + +M: array pprint-slot-name + + \ } pprint-word block> ; + M: tuple-class see-class* pprint-; block> ; M: word see-class* drop ; @@ -282,14 +291,6 @@ M: word see-class* drop ; M: builtin-class see-class* drop "! Built-in class" comment. ; -: see-all ( seq -- ) - natural-sort [ nl see ] each ; - -: see-implementors ( class -- seq ) - dup implementors - [ method ] with map - natural-sort ; - : see-class ( class -- ) dup class? [ [ @@ -297,9 +298,6 @@ M: builtin-class see-class* ] with-use nl ] when drop ; -: see-methods ( generic -- seq ) - "methods" word-prop values natural-sort ; - M: word see dup see-class dup class? over symbol? not and [ @@ -308,8 +306,20 @@ M: word see dup class? over symbol? and not [ [ dup (see) ] with-use nl ] when + drop ; + +: see-all ( seq -- ) + natural-sort [ nl ] [ see ] interleave ; + +: (see-implementors) ( class -- seq ) + dup implementors [ method ] with map natural-sort ; + +: (see-methods) ( generic -- seq ) + "methods" word-prop values natural-sort ; + +: see-methods ( word -- ) [ - dup class? [ dup see-implementors % ] when - dup generic? [ dup see-methods % ] when + dup class? [ dup (see-implementors) % ] when + dup generic? [ dup (see-methods) % ] when drop ] { } make prune see-all ; diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 113d5eabe4..1bef47e759 100755 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -5,8 +5,8 @@ strings growable strings.private ; IN: sbufs TUPLE: sbuf -{ "underlying" string } -{ "length" array-capacity } ; +{ underlying string } +{ length array-capacity } ; reversed -M: reversed virtual-seq reversed-seq ; +M: reversed virtual-seq seq>> ; -M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ; +M: reversed virtual@ seq>> [ length swap - 1- ] keep ; -M: reversed length reversed-seq length ; +M: reversed length seq>> length ; INSTANCE: reversed virtual-sequence : reverse ( seq -- newseq ) [ ] [ like ] bi ; ! A slice of another sequence. -TUPLE: slice from to seq ; +TUPLE: slice +{ from read-only: t } +{ to read-only: t } +{ seq read-only: t } ; : collapse-slice ( m n slice -- m' n' seq ) - dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline + [ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline ERROR: slice-error reason ; @@ -193,11 +196,11 @@ ERROR: slice-error reason ; check-slice slice boa ; inline -M: slice virtual-seq slice-seq ; +M: slice virtual-seq seq>> ; -M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ; +M: slice virtual@ [ from>> + ] [ seq>> ] bi ; -M: slice length dup slice-to swap slice-from - ; +M: slice length [ to>> ] [ from>> ] bi - ; : short ( seq n -- seq n' ) over length min ; inline @@ -216,12 +219,12 @@ M: slice length dup slice-to swap slice-from - ; INSTANCE: slice virtual-sequence ! One element repeated many times -TUPLE: repetition len elt ; +TUPLE: repetition { len read-only: t } { elt read-only: t } ; C: repetition -M: repetition length repetition-len ; -M: repetition nth-unsafe nip repetition-elt ; +M: repetition length len>> ; +M: repetition nth-unsafe nip elt>> ; INSTANCE: repetition immutable-sequence diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index d47ef7b9bb..fd9796e664 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -16,12 +16,17 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ; swap "declared-effect" set-word-prop slot-spec-reader swap "reading" set-word-prop ; +: define-slot-word ( class word quot -- ) + [ + dup define-simple-generic + create-method + ] dip define ; + : define-reader ( class spec -- ) dup slot-spec-reader [ [ set-reader-props ] 2keep - dup slot-spec-offset - over slot-spec-reader - rot slot-spec-class reader-quot + dup slot-spec-reader + swap reader-quot define-slot-word ] [ 2drop @@ -41,9 +46,8 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : define-writer ( class spec -- ) dup slot-spec-writer [ [ set-writer-props ] 2keep - dup slot-spec-offset - swap slot-spec-writer - [ set-slot ] + dup slot-spec-writer + swap writer-quot define-slot-word ] [ 2drop diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 2b9631695a..32b3bc2ecb 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -113,11 +113,6 @@ HELP: define-typecheck } { $notes "This word is used internally to wrap unsafe low-level code in a type-checking stub." } ; -HELP: define-slot-word -{ $values { "class" class } { "slot" "a positive integer" } { "word" word } { "quot" quotation } } -{ $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." } -$low-level-note ; - HELP: define-reader { $values { "class" class } { "name" string } { "slot" integer } } { $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." } diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 16196bf844..61cec47c94 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -1,13 +1,14 @@ IN: slots.tests -USING: math accessors slots strings generic.standard kernel tools.test ; +USING: math accessors slots strings generic.standard kernel +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: t } ; [ r/o-test new 123 >>foo ] [ no-method? ] must-fail-with -TUPLE: decl-test { "foo" integer } ; +TUPLE: decl-test { foo integer } ; [ decl-test new 1.0 >>foo ] [ bad-slot-value? ] must-fail-with @@ -16,3 +17,20 @@ TUPLE: hello length ; [ 3 ] [ "xyz" length>> ] unit-test [ "xyz" 4 >>length ] [ no-method? ] must-fail-with + +[ t ] [ r/o-test \ foo>> method "foldable" word-prop ] unit-test +[ t ] [ r/o-test \ foo>> method "flushable" word-prop ] unit-test + +[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test +[ 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 + +[ 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 + +[ 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 f033c18646..86f9cba9fe 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -3,7 +3,7 @@ USING: arrays bit-arrays byte-arrays float-arrays kernel kernel.private math namespaces sequences strings words effects generic generic.standard classes classes.algebra slots.private -combinators accessors words ; +combinators accessors words sequences.private assocs ; IN: slots TUPLE: slot-spec name offset class initial read-only reader writer ; @@ -12,69 +12,71 @@ TUPLE: slot-spec name offset class initial read-only reader writer ; slot-spec new object bootstrap-word >>class ; -: define-typecheck ( class generic quot -- ) - [ - dup define-simple-generic - create-method - ] dip define ; - -: define-slot-word ( class offset word quot -- ) - rot >fixnum prefix define-typecheck ; +: define-typecheck ( class generic quot props -- ) + [ dup define-simple-generic create-method ] 2dip + [ [ props>> ] [ drop ] [ [ t ] H{ } map>assoc ] tri* update ] + [ drop define ] + 3bi ; : create-accessor ( name effect -- word ) >r "accessors" create dup r> "declared-effect" set-word-prop ; -: reader-quot ( decl -- quot ) +: reader-quot ( slot-spec -- quot ) [ + dup offset>> , \ slot , - dup object bootstrap-word eq? - [ drop ] [ 1array , \ declare , ] if + dup class>> object bootstrap-word eq? + [ drop ] [ class>> 1array , \ declare , ] if ] [ ] make ; : reader-word ( name -- word ) ">>" append (( object -- value )) create-accessor ; +: reader-props ( slot-spec -- seq ) + read-only>> { "foldable" "flushable" } { "flushable" } ? ; + : define-reader ( class slot-spec -- ) - [ offset>> ] - [ name>> reader-word ] - [ class>> reader-quot ] - tri define-slot-word ; + [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri + define-typecheck ; : writer-word ( name -- word ) "(>>" swap ")" 3append (( value object -- )) create-accessor ; ERROR: bad-slot-value value object index ; -: writer-quot/object ( decl -- ) - drop \ set-slot , ; +: writer-quot/object ( slot-spec -- ) + offset>> , \ set-slot , ; -: writer-quot/coerce ( decl -- ) - [ rot ] % "coercer" word-prop % [ -rot set-slot ] % ; +: writer-quot/coerce ( slot-spec -- ) + [ \ >r , class>> "coercer" word-prop % \ r> , ] + [ offset>> , \ set-slot , ] + bi ; -: writer-quot/check ( decl -- ) - \ pick , - "predicate" word-prop % - [ [ set-slot ] [ bad-slot-value ] if ] % ; +: writer-quot/check ( slot-spec -- ) + [ offset>> , ] + [ + \ pick , + class>> "predicate" word-prop % + [ [ set-slot ] [ bad-slot-value ] if ] % + ] + bi ; -: writer-quot/fixnum ( decl -- ) - [ rot >fixnum -rot ] % writer-quot/check ; +: writer-quot/fixnum ( slot-spec -- ) + [ >r >fixnum r> ] % writer-quot/check ; -: writer-quot ( decl -- quot ) +: writer-quot ( slot-spec -- quot ) [ { - { [ dup object bootstrap-word eq? ] [ writer-quot/object ] } - { [ dup "coercer" word-prop ] [ writer-quot/coerce ] } - { [ dup fixnum class<= ] [ writer-quot/fixnum ] } + { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] } + { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] } + { [ dup class>> fixnum bootstrap-word class<= ] [ writer-quot/fixnum ] } [ writer-quot/check ] } cond ] [ ] make ; : define-writer ( class slot-spec -- ) - [ offset>> ] - [ name>> writer-word ] - [ class>> writer-quot ] - tri define-slot-word ; + [ name>> writer-word ] [ writer-quot ] bi { } define-typecheck ; : setter-word ( name -- word ) ">>" prepend (( object value -- object )) create-accessor ; @@ -123,13 +125,14 @@ ERROR: no-initial-value class ; : initial-value ( class -- object ) { - { [ \ f over class<= ] [ f ] } - { [ fixnum over class<= ] [ 0 ] } - { [ float over class<= ] [ 0.0 ] } - { [ array over class<= ] [ { } ] } - { [ bit-array over class<= ] [ ?{ } ] } - { [ byte-array over class<= ] [ B{ } ] } - { [ float-array over class<= ] [ F{ } ] } + { [ \ f bootstrap-word over class<= ] [ f ] } + { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] } + { [ float bootstrap-word over class<= ] [ 0.0 ] } + { [ string bootstrap-word over class<= ] [ "" ] } + { [ array bootstrap-word over class<= ] [ { } ] } + { [ bit-array bootstrap-word over class<= ] [ ?{ } ] } + { [ byte-array bootstrap-word over class<= ] [ B{ } ] } + { [ float-array bootstrap-word over class<= ] [ F{ } ] } [ no-initial-value ] } cond nip ; @@ -164,8 +167,10 @@ ERROR: bad-initial-value name ; : check-initial-value ( slot-spec -- slot-spec ) dup initial>> [ - dup [ initial>> ] [ class>> ] bi instance? - [ name>> bad-initial-value ] unless + [ ] [ + dup [ initial>> ] [ class>> ] bi instance? + [ name>> bad-initial-value ] unless + ] if-bootstrapping ] [ dup class>> initial-value >>initial ] if ; diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index b54b2bc91a..fa900af69a 100755 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -4,8 +4,8 @@ USING: arrays kernel math sequences sequences.private growable ; IN: vectors TUPLE: vector -{ "underlying" array } -{ "length" array-capacity } ; +{ underlying array } +{ length array-capacity } ; ( n -- buffer ) diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor index eb26232969..955d1b2596 100755 --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -2,7 +2,10 @@ USING: kernel layouts math math.order namespaces sequences sequences.private accessors ; IN: math.ranges -TUPLE: range from length step ; +TUPLE: range +{ from read-only: t } +{ length read-only: t } +{ step read-only: t } ; : ( a b step -- range ) >r over - r> @@ -23,19 +26,19 @@ INSTANCE: range immutable-sequence : ,b) dup neg rot + swap ; inline -: [a,b] ( a b -- range ) twiddle ; +: [a,b] ( a b -- range ) twiddle ; foldable -: (a,b] ( a b -- range ) twiddle (a, ; +: (a,b] ( a b -- range ) twiddle (a, ; foldable -: [a,b) ( a b -- range ) twiddle ,b) ; +: [a,b) ( a b -- range ) twiddle ,b) ; foldable -: (a,b) ( a b -- range ) twiddle (a, ,b) ; +: (a,b) ( a b -- range ) twiddle (a, ,b) ; foldable -: [0,b] ( b -- range ) 0 swap [a,b] ; +: [0,b] ( b -- range ) 0 swap [a,b] ; foldable -: [1,b] ( b -- range ) 1 swap [a,b] ; +: [1,b] ( b -- range ) 1 swap [a,b] ; foldable -: [0,b) ( b -- range ) 0 swap [a,b) ; +: [0,b) ( b -- range ) 0 swap [a,b) ; foldable : range-increasing? ( range -- ? ) step>> 0 > ;