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

More tuple declaration work

db4
Slava Pestov 2008-06-29 21:37:57 -05:00
parent 7a7f0009af
commit 3b41e31584
24 changed files with 226 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
core/bootstrap/primitives.factor
View File

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

4
core/byte-vectors/byte-vectors.factor
View File

@ -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 } ;
<PRIVATE

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

@ -21,21 +21,21 @@ TUPLE: test-4 < test-3 b ;
[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test
TUPLE: test-5 { "a" integer } ;
TUPLE: test-5 { a integer } ;
[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test
TUPLE: test-6 < test-5 { "b" integer } ;
TUPLE: test-6 < test-5 { b integer } ;
[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] 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

5
core/classes/tuple/parser/parser.factor
View File

@ -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 ( -- )

2
core/generic/generic.factor
View File

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

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 n ;
TUPLE: abstract-groups { seq read-only: t } { n read-only: t } ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline

6
core/hashtables/hashtables.factor
View File

@ -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 } ;
<PRIVATE

7
core/inference/class/class-tests.factor
View File

@ -579,13 +579,18 @@ M: integer detect-integer ;
[ hashtable instance? ] \ instance? inlined?
] unit-test
TUPLE: declared-fixnum { "x" fixnum } ;
TUPLE: declared-fixnum { x fixnum } ;
[ t ] [
[ { declared-fixnum } declare [ 1 + ] change-x ]
{ + fixnum+ >fixnum } inlined?
] unit-test
[ t ] [
[ { declared-fixnum } declare x>> drop ]
{ slot } inlined?
] unit-test
! Later
! [ t ] [

4
core/inspector/inspector.factor
View File

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

8
core/mirrors/mirrors-tests.factor
View File

@ -31,7 +31,7 @@ C: <foo> foo
[ gensym <mirror> [ "compiled" off ] bind ] must-fail
TUPLE: declared-mirror-test
{ "a" integer initial: 0 } ;
{ a integer initial: 0 } ;
[ 5 ] [
3 declared-mirror-test boa <mirror> [
@ -43,9 +43,9 @@ TUPLE: declared-mirror-test
[ 3 declared-mirror-test boa <mirror> [ 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 [ <mirror> clear-assoc ] keep

12
core/optimizer/inlining/inlining.factor
View File

@ -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>> <reversed> ?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>> <reversed> ?nth 2dup node-literal?
[ node-literal swap single-effective-method ]
[ node-class swap specific-method ]
if ;
tuck dispatch# over in-d>> <reversed> ?nth
node-class swap specific-method ;
: inline-standard-method ( node generic -- node )
dupd dispatching-class dup

51
core/prettyprint/prettyprint-tests.factor
View File

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

38
core/prettyprint/prettyprint.factor
View File

@ -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
<flow \ { pprint-word
f <inset unclip text pprint-elements block>
\ } pprint-word block> ;
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
slot-names [ dup string? [ text ] [ pprint* ] if ] each
<block slot-names [ pprint-slot-name ] each block>
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 ;

4
core/sbufs/sbufs.factor
View File

@ -5,8 +5,8 @@ strings growable strings.private ;
IN: sbufs
TUPLE: sbuf
{ "underlying" string }
{ "length" array-capacity } ;
{ underlying string }
{ length array-capacity } ;
<PRIVATE

31
core/sequences/sequences.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private slots.private math math.private
math.order ;
USING: accessors kernel kernel.private slots.private math
math.private math.order ;
IN: sequences
MIXIN: sequence
@ -161,25 +161,28 @@ M: virtual-sequence new-sequence virtual-seq new-sequence ;
INSTANCE: virtual-sequence sequence
! A reversal of an underlying sequence.
TUPLE: reversed seq ;
TUPLE: reversed { seq read-only: t } ;
C: <reversed> 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 ) [ <reversed> ] [ 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> 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

16
core/slots/deprecated/deprecated.factor
View File

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

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

@ -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" } "." }

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

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

85
core/slots/slots.factor
View File

@ -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 -- )
: writer-quot/check ( slot-spec -- )
[ offset>> , ]
[
\ pick ,
"predicate" word-prop %
[ [ set-slot ] [ bad-slot-value ] if ] % ;
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
] if-bootstrapping
] [
dup class>> initial-value >>initial
] if ;

4
core/vectors/vectors.factor
View File

@ -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 } ;
<PRIVATE

4
extra/bit-vectors/bit-vectors.factor
View File

@ -6,8 +6,8 @@ parser accessors ;
IN: bit-vectors
TUPLE: bit-vector
{ "underlying" bit-array }
{ "length" array-capacity } ;
{ underlying bit-array }
{ length array-capacity } ;
<PRIVATE

4
extra/float-vectors/float-vectors.factor
View File

@ -6,8 +6,8 @@ parser accessors ;
IN: float-vectors
TUPLE: float-vector
{ "underlying" float-array }
{ "length" array-capacity } ;
{ underlying float-array }
{ length array-capacity } ;
<PRIVATE

8
extra/io/buffers/buffers.factor
View File

@ -7,10 +7,10 @@ hints accessors math.order destructors combinators ;
IN: io.buffers
TUPLE: buffer
{ "size" fixnum }
{ "ptr" simple-alien }
{ "fill" fixnum }
{ "pos" fixnum }
{ size fixnum }
{ ptr simple-alien initial: ALIEN: -1 }
{ fill fixnum }
{ pos fixnum }
disposed ;
: <buffer> ( n -- buffer )

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

@ -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 } ;
: <range> ( 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 <range> ;
: [a,b] ( a b -- range ) twiddle <range> ; foldable
: (a,b] ( a b -- range ) twiddle (a, <range> ;
: (a,b] ( a b -- range ) twiddle (a, <range> ; foldable
: [a,b) ( a b -- range ) twiddle ,b) <range> ;
: [a,b) ( a b -- range ) twiddle ,b) <range> ; foldable
: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ;
: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ; 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 > ;