"classes.private"
"classes.tuple"
"classes.tuple.private"
+ "classes.predicate"
"compiler.units"
"continuations.private"
"float-arrays"
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
"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
{ "hashcode" { "fixnum" "math" } }
"name"
"vocabulary"
- { "def" { "quotation" "quotations" } }
+ { "def" { "quotation" "quotations" } initial: [ ] }
"props"
{ "compiled" read-only: t }
{ "counter" { "fixnum" "math" } }
"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
IN: byte-vectors\r
\r
TUPLE: byte-vector\r
-{ "underlying" byte-array }\r
-{ "length" array-capacity } ;\r
+{ underlying byte-array }\r
+{ length array-capacity } ;\r
\r
<PRIVATE\r
\r
[ { "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
[ 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
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:
{ [ 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 ( -- )
: 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 =
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
IN: hashtables
TUPLE: hashtable
-{ "count" array-capacity }
-{ "deleted" array-capacity }
-{ "array" array } ;
+{ count array-capacity }
+{ deleted array-capacity }
+{ array array } ;
<PRIVATE
[ 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 ] [
: 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 [
[ 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> [
[ 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
[ 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
] 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\""
""
"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
"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 ;"
"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
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 ;
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? [
[
] 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 [
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 ;
IN: sbufs
TUPLE: sbuf
-{ "underlying" string }
-{ "length" array-capacity } ;
+{ underlying string }
+{ length array-capacity } ;
<PRIVATE
! 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
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 ;
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
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
swap "declared-effect" set-word-prop\r
slot-spec-reader swap "reading" set-word-prop ;\r
\r
+: define-slot-word ( class word quot -- )\r
+ [\r
+ dup define-simple-generic\r
+ create-method\r
+ ] dip define ;\r
+\r
: define-reader ( class spec -- )\r
dup slot-spec-reader [\r
[ set-reader-props ] 2keep\r
- dup slot-spec-offset\r
- over slot-spec-reader\r
- rot slot-spec-class reader-quot\r
+ dup slot-spec-reader\r
+ swap reader-quot\r
define-slot-word\r
] [\r
2drop\r
: define-writer ( class spec -- )\r
dup slot-spec-writer [\r
[ set-writer-props ] 2keep\r
- dup slot-spec-offset\r
- swap slot-spec-writer\r
- [ set-slot ]\r
+ dup slot-spec-writer\r
+ swap writer-quot\r
define-slot-word\r
] [\r
2drop\r
}
{ $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" } "." }
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
[ 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
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 ;
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 ;
: 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 ;
: 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 ;
IN: vectors
TUPLE: vector
-{ "underlying" array }
-{ "length" array-capacity } ;
+{ underlying array }
+{ length array-capacity } ;
<PRIVATE
IN: bit-vectors\r
\r
TUPLE: bit-vector\r
-{ "underlying" bit-array }\r
-{ "length" array-capacity } ;\r
+{ underlying bit-array }\r
+{ length array-capacity } ;\r
\r
<PRIVATE\r
\r
IN: float-vectors\r
\r
TUPLE: float-vector\r
-{ "underlying" float-array }\r
-{ "length" array-capacity } ;\r
+{ underlying float-array }\r
+{ length array-capacity } ;\r
\r
<PRIVATE\r
\r
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 )
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>
: ,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 > ;
projects / factor.git / commitdiff