HELP: dll
{ $class-description "The class of native library handles. See " { $link "syntax-aliens" } " for syntax and " { $link "dll.private" } " for general information." } ;
-HELP: expired? ( c-ptr -- ? )
+HELP: expired?
{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } }
{ $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired."
$nl
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math namespaces sequences system
+USING: accessors assocs kernel math namespaces sequences system
kernel.private bit-arrays byte-arrays float-arrays arrays ;
IN: alien
! Some predicate classes used by the compiler for optimization
! purposes
-PREDICATE: simple-alien < alien
- underlying-alien not ;
+PREDICATE: simple-alien < alien underlying>> not ;
UNION: simple-c-ptr
simple-alien POSTPONE: f byte-array bit-array float-array ;
DEFER: pinned-c-ptr?
-PREDICATE: pinned-alien < alien
- underlying-alien pinned-c-ptr? ;
+PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
UNION: pinned-c-ptr
pinned-alien POSTPONE: f ;
+GENERIC: expired? ( c-ptr -- ? )
+
+M: alien expired? expired?>> ;
+
M: f expired? drop t ;
: <alien> ( address -- alien )
} 2cleave ;
: expand-constants ( c-type -- c-type' )
- #! We use word-def call instead of execute to get around
+ #! We use def>> call instead of execute to get around
#! staging violations
dup array? [
- unclip >r [ dup word? [ word-def call ] when ] map
- r> prefix
+ unclip >r [ dup word? [ def>> call ] when ] map r> prefix
] when ;
: malloc-file-contents ( path -- alien len )
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings parser threads words
-kernel.private kernel io.encodings.utf8 ;
+USING: accessors alien alien.c-types alien.strings parser
+threads words kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control
: eval-callback ( -- callback )
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
- dup compiled? [ execute ] [ drop f ] if ; inline
+ dup compiled>> [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv
os windows? [ utf16n ] [ utf8 ] if alien>string ;
: dll-path ( dll -- string )
- (dll-path) alien>native-string ;
+ path>> alien>native-string ;
: string>symbol ( str -- alien )
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
: ($spec-reader-values) ( slot-spec class -- element )
dup ?word-name swap 2array
over slot-spec-name
- rot slot-spec-type 2array 2array
+ rot slot-spec-class 2array 2array
[ { $instance } swap suffix ] assoc-map ;
: $spec-reader-values ( slot-spec class -- )
" instance." ,
] { } make $description ;
+: slot-of-reader ( reader specs -- spec/f )
+ [ slot-spec-reader eq? ] with find nip ;
+
: $spec-reader ( reader slot-specs class -- )
>r slot-of-reader r>
over [
" instance." ,
] { } make $description ;
+: slot-of-writer ( writer specs -- spec/f )
+ [ slot-spec-writer eq? ] with find nip ;
+
: $spec-writer ( writer slot-specs class -- )
>r slot-of-writer r>
over [
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic hashtables kernel kernel.private math
-namespaces parser sequences strings words libc slots
+USING: accessors arrays generic hashtables kernel kernel.private
+math namespaces parser sequences strings words libc slots
slots.deprecated alien.c-types cpu.architecture ;
IN: alien.structs
: struct-offsets ( specs -- size )
0 [
- [ slot-spec-type align-offset ] keep
+ [ class>> align-offset ] keep
[ set-slot-spec-offset ] 2keep
- slot-spec-type heap-size +
+ class>> heap-size +
] reduce ;
: define-struct-slot-word ( spec word quot -- )
[ ]
[ slot-spec-reader ]
[
- slot-spec-type
+ class>>
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ;
[ set-writer-props ] keep
[ ]
[ slot-spec-writer ]
- [ slot-spec-type c-setter ] tri
+ [ class>> c-setter ] tri
define-struct-slot-word ;
: define-field ( type spec -- )
-rot define-c-type ;
: make-field ( struct-name vocab type field-name -- spec )
- [
- -rot expand-constants ,
- over ,
- 3dup reader-word ,
- writer-word ,
- ] { } make
- first4 0 -rot <slot-spec> ;
+ <slot-spec>
+ 0 >>offset
+ swap >>name
+ swap expand-constants >>class
+ 3dup name>> swap reader-word >>reader
+ 3dup name>> swap writer-word >>writer
+ 2nip ;
: define-struct-early ( name vocab fields -- fields )
-rot [ rot first2 make-field ] 2curry map ;
: define-struct ( name vocab fields -- )
pick >r
[ struct-offsets ] keep
- [ [ slot-spec-type ] map compute-struct-align ] keep
+ [ [ class>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
r> [ swap define-field ] curry each ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler cpu.architecture vocabs.loader system sequences
-namespaces parser kernel kernel.private classes classes.private
-arrays hashtables vectors classes.tuple sbufs inference.dataflow
-hashtables.private sequences.private math classes.tuple.private
-growable namespaces.private assocs words generator command-line
-vocabs io prettyprint libc compiler.units math.order ;
+USING: accessors compiler cpu.architecture vocabs.loader system
+sequences namespaces parser kernel kernel.private classes
+classes.private arrays hashtables vectors classes.tuple sbufs
+inference.dataflow hashtables.private sequences.private math
+classes.tuple.private growable namespaces.private assocs words
+generator command-line vocabs io prettyprint libc compiler.units
+math.order ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
"alien.remote-control" require
] unless
-"cpu." cpu word-name append require
+"cpu." cpu name>> append require
enable-compiler
: compile-uncompiled ( words -- )
- [ compiled? not ] filter compile ;
+ [ compiled>> not ] filter compile ;
nl
"Compiling..." write flush
wrap probe
- underlying
-
namestack*
bitand bitor bitxor bitnot
IN: bootstrap.image
: my-arch ( -- arch )
- cpu word-name
- dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
+ cpu name>>
+ dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
[
{
[ hashcode , ]
- [ word-name , ]
- [ word-vocabulary , ]
- [ word-def , ]
- [ word-props , ]
+ [ name>> , ]
+ [ vocabulary>> , ]
+ [ def>> , ]
+ [ props>> , ]
} cleave
f ,
0 , ! count
] keep put-object ;
: word-error ( word msg -- * )
- [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
+ [ % dup vocabulary>> % " " % name>> % ] "" make throw ;
: transfer-word ( word -- word )
[ target-word ] keep or ;
! Wrappers
M: wrapper '
- wrapped ' wrapper type-number object tag-number
+ wrapped>> ' wrapper type-number object tag-number
[ emit ] emit-object ;
! Strings
tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
- dup class word-name "tombstone" =
+ dup class name>> "tombstone" =
[ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
M: tuple ' emit-tuple ;
[
[
{
- [ layout-hashcode , ]
- [ layout-class , ]
- [ layout-size , ]
- [ layout-superclasses , ]
- [ layout-echelon , ]
+ [ hashcode>> , ]
+ [ class>> , ]
+ [ size>> , ]
+ [ superclasses>> , ]
+ [ echelon>> , ]
} cleave
] { } make [ ' ] map
\ tuple-layout type-number
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
- word-def first [ emit-tuple ] cache-object ;
+ def>> first [ emit-tuple ] cache-object ;
! Arrays
M: array '
M: quotation '
[
- quotation-array '
+ array>> '
quotation type-number object tag-number [
emit ! array
- f ' emit ! compiled?
+ f ' emit ! compiled>>
0 emit ! xt
0 emit ! code
] emit-object
strings vectors words quotations assocs layouts classes
classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
-slots.deprecated classes.union classes.intersection
+slots classes.union classes.intersection
compiler.units bootstrap.image.private io.files accessors
combinators ;
IN: bootstrap.primitives
[ f f f builtin-class define-class ]
tri ;
-: define-builtin-slots ( symbol slotspec -- )
- [ drop ] [ 1 simple-slots ] 2bi
- [ "slots" set-word-prop ] [ define-slots ] 2bi ;
+: prepare-slots ( slots -- slots' )
+ [ [ dup array? [ first2 create ] when ] map ] map ;
+
+: define-builtin-slots ( class slots -- )
+ prepare-slots 1 make-slots
+ [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin ( symbol slotspec -- )
>r [ define-builtin-predicate ] keep
"ratio" "math" create {
{
- { "integer" "math" }
"numerator"
- { "numerator" "math" }
- f
+ { "integer" "math" }
+ read-only: t
}
{
- { "integer" "math" }
"denominator"
- { "denominator" "math" }
- f
+ { "integer" "math" }
+ read-only: t
}
} define-builtin
"complex" "math" create {
{
+ "real"
{ "real" "math" }
- "real-part"
- { "real-part" "math" }
- f
+ read-only: t
}
{
+ "imaginary"
{ "real" "math" }
- "imaginary-part"
- { "imaginary-part" "math" }
- f
+ read-only: t
}
} define-builtin
"wrapper" "kernel" create {
{
- { "object" "kernel" }
"wrapped"
- { "wrapped" "kernel" }
- f
+ { "object" "kernel" }
+ read-only: t
}
} define-builtin
"string" "strings" create {
{
- { "array-capacity" "sequences.private" }
"length"
- { "length" "sequences" }
- f
+ { "array-capacity" "sequences.private" }
+ read-only: t
} {
- { "object" "kernel" }
"aux"
- { "string-aux" "strings.private" }
- { "set-string-aux" "strings.private" }
+ { "object" "kernel" }
}
} define-builtin
"quotation" "quotations" create {
{
- { "object" "kernel" }
"array"
- { "quotation-array" "quotations.private" }
- f
+ { "object" "kernel" }
+ read-only: t
}
{
+ "compiled"
{ "object" "kernel" }
- "compiled?"
- { "quotation-compiled?" "quotations" }
- f
+ read-only: t
}
} define-builtin
"dll" "alien" create {
{
- { "byte-array" "byte-arrays" }
- "path"
- { "(dll-path)" "alien" }
- f
+ "path"
+ { "byte-array" "byte-arrays" }
+ read-only: t
}
}
define-builtin
"alien" "alien" create {
{
+ "underlying"
{ "c-ptr" "alien" }
- "alien"
- { "underlying-alien" "alien" }
- f
+ read-only: t
} {
- { "object" "kernel" }
"expired?"
- { "expired?" "alien" }
- f
+ { "object" "kernel" }
+ read-only: t
}
}
define-builtin
"word" "words" create {
- f
{
- { "object" "kernel" }
- "name"
- { "word-name" "words" }
- { "set-word-name" "words" }
+ "hashcode"
+ { "fixnum" "math" }
}
{
+ "name"
{ "object" "kernel" }
+ }
+ {
"vocabulary"
- { "word-vocabulary" "words" }
- { "set-word-vocabulary" "words" }
+ { "object" "kernel" }
}
{
- { "quotation" "quotations" }
"def"
- { "word-def" "words" }
- { "set-word-def" "words.private" }
+ { "quotation" "quotations" }
}
{
- { "object" "kernel" }
"props"
- { "word-props" "words" }
- { "set-word-props" "words" }
+ { "object" "kernel" }
}
{
+ "compiled"
{ "object" "kernel" }
- "compiled?"
- { "compiled?" "words" }
- f
+ read-only: t
}
{
- { "fixnum" "math" }
"counter"
- { "profile-counter" "tools.profiler.private" }
- { "set-profile-counter" "tools.profiler.private" }
+ { "fixnum" "math" }
}
} define-builtin
"tuple-layout" "classes.tuple.private" create {
{
- { "fixnum" "math" }
"hashcode"
- { "layout-hashcode" "classes.tuple.private" }
- f
+ { "fixnum" "math" }
+ read-only: t
}
{
- { "word" "words" }
"class"
- { "layout-class" "classes.tuple.private" }
- f
+ { "word" "words" }
+ read-only: t
}
{
- { "fixnum" "math" }
"size"
- { "layout-size" "classes.tuple.private" }
- f
+ { "fixnum" "math" }
+ read-only: t
}
{
- { "array" "arrays" }
"superclasses"
- { "layout-superclasses" "classes.tuple.private" }
- f
+ { "array" "arrays" }
+ read-only: t
}
{
- { "fixnum" "math" }
"echelon"
- { "layout-echelon" "classes.tuple.private" }
- f
+ { "fixnum" "math" }
+ read-only: t
}
} define-builtin
[
{
{
- { "object" "kernel" }
"delegate"
- { "delegate" "kernel" }
- { "set-delegate" "kernel" }
+ { "object" "kernel" }
}
- }
+ } prepare-slots
[ drop ] [ generate-tuple-slots ] 2bi
[ "slots" set-word-prop ]
- [ define-slots ]
+ [ define-accessors ]
2bi
]
} cleave
2array >tuple 1quotation define-inline
! Some tuple classes
-"hashtable" "hashtables" create
-tuple
-{
- {
- { "array-capacity" "sequences.private" }
- "count"
- { "hash-count" "hashtables.private" }
- { "set-hash-count" "hashtables.private" }
- } {
- { "array-capacity" "sequences.private" }
- "deleted"
- { "hash-deleted" "hashtables.private" }
- { "set-hash-deleted" "hashtables.private" }
- } {
- { "array" "arrays" }
- "array"
- { "hash-array" "hashtables.private" }
- { "set-hash-array" "hashtables.private" }
- }
-} define-tuple-class
-
-"sbuf" "sbufs" create
-tuple
-{
- {
- { "string" "strings" }
- "underlying"
- { "underlying" "growable" }
- { "set-underlying" "growable" }
- } {
- { "array-capacity" "sequences.private" }
- "length"
- { "length" "sequences" }
- { "set-fill" "growable" }
- }
-} define-tuple-class
-
-"vector" "vectors" create
-tuple
-{
- {
- { "array" "arrays" }
- "underlying"
- { "underlying" "growable" }
- { "set-underlying" "growable" }
- } {
- { "array-capacity" "sequences.private" }
- "fill"
- { "length" "sequences" }
- { "set-fill" "growable" }
- }
-} define-tuple-class
-
-"byte-vector" "byte-vectors" create
-tuple
-{
- {
- { "byte-array" "byte-arrays" }
- "underlying"
- { "underlying" "growable" }
- { "set-underlying" "growable" }
- } {
- { "array-capacity" "sequences.private" }
- "fill"
- { "length" "sequences" }
- { "set-fill" "growable" }
- }
-} define-tuple-class
-
"curry" "kernel" create
tuple
{
{
- { "object" "kernel" }
"obj"
- { "curry-obj" "kernel" }
- f
- } {
{ "object" "kernel" }
+ read-only: t
+ } {
"quot"
- { "curry-quot" "kernel" }
- f
+ { "object" "kernel" }
+ read-only: t
}
-} define-tuple-class
+} prepare-slots define-tuple-class
"curry" "kernel" lookup
[ f "inline" set-word-prop ]
tuple
{
{
- { "object" "kernel" }
"first"
- { "compose-first" "kernel" }
- f
- } {
{ "object" "kernel" }
+ read-only: t
+ } {
"second"
- { "compose-second" "kernel" }
- f
+ { "object" "kernel" }
+ read-only: t
}
-} define-tuple-class
+} prepare-slots define-tuple-class
"compose" "kernel" lookup
[ f "inline" set-word-prop ]
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: init command-line namespaces words debugger io
+USING: accessors init command-line namespaces words debugger io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
"Bootstrap completed in " write number>string write
" minutes and " write number>string write " seconds." print
- [ compiled? ] count-words " compiled words" print
+ [ compiled>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
"SINGLETON:"
"SYMBOL:"
"TUPLE:"
+ "SLOT:"
"T{"
"UNION:"
"INTERSECTION:"
"<<"
">>"
"call-next-method"
+ "initial:"
+ "read-only:"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol
sequences.private growable byte-arrays ;\r
IN: byte-vectors\r
\r
+TUPLE: byte-vector\r
+{ "underlying" byte-array }\r
+{ "length" array-capacity } ;\r
+\r
<PRIVATE\r
\r
: byte-array>vector ( byte-array length -- byte-vector )\r
[ "Topological sort failed" throw ] unless* ;\r
\r
: sort-classes ( seq -- newseq )\r
- [ [ word-name ] compare ] sort >vector\r
+ [ [ name>> ] compare ] sort >vector\r
[ dup empty? not ]\r
[ dup largest-class >r over delete-nth r> ]\r
[ ] unfold nip ;\r
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions assocs kernel kernel.private
+USING: accessors arrays definitions assocs kernel kernel.private
slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs sets ;
IN: classes
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )
- [ word-name "?" append ] keep word-vocabulary create ;
+ [ name>> "?" append ] [ vocabulary>> ] bi create ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
- dup word-props
- r> assoc-union over set-word-props
+ dup props>>
+ r> assoc-union >>props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
--- /dev/null
+IN: classes.tuple.parser.tests
+USING: accessors classes.tuple.parser lexer words classes
+sequences math kernel slots tools.test parser compiler.units ;
+
+TUPLE: test-1 ;
+
+[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test
+
+TUPLE: test-2 < test-1 ;
+
+[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test
+[ test-1 ] [ test-2 superclass ] unit-test
+
+TUPLE: test-3 a ;
+
+[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test
+
+[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
+
+TUPLE: test-4 < test-3 b ;
+
+[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test
+
+TUPLE: test-5 { "a" integer } ;
+
+[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test
+
+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 } ;
+
+[ 3 ] [ "b" test-7 "slots" word-prop slot-named initial>> ] unit-test
+
+TUPLE: test-8 { "b" integer read-only: t } ;
+
+[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test
+
+[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
+[ error>> invalid-slot-name? ]
+must-fail-with
+
+[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ]
+[ error>> invalid-slot-name? ]
+must-fail-with
+
+[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ]
+[ error>> unexpected-eof? ]
+must-fail-with
+
+[ ] [
+ [
+ { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 }
+ [ dup class? [ forget-class ] [ drop ] if ] each
+ ] with-compilation-unit
+] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sets namespaces sequences inspector parser
-lexer combinators words classes.parser classes.tuple ;
+USING: accessors kernel sets namespaces sequences inspector parser
+lexer combinators words classes.parser classes.tuple arrays ;
IN: classes.tuple.parser
: shadowed-slots ( superclass slots -- shadowed )
"Definition of slot ``" %
%
"'' in class ``" %
- word-name %
+ name>> %
"'' shadows a superclass slot" %
] "" make note.
] with each ;
drop
"Invalid slot name" ;
-: (parse-tuple-slots) ( -- )
+: parse-slot-name ( string/f -- ? )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
#! TUPLE: blahblah foo bing
#!
#! : ...
- scan {
+ {
{ [ dup not ] [ unexpected-eof ] }
- { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
- { [ dup ";" = ] [ drop ] }
- [ , (parse-tuple-slots) ]
+ { [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
+ { [ dup ";" = ] [ drop f ] }
+ [ dup "{" = [ drop \ } parse-until >array ] when , t ]
} cond ;
-: parse-tuple-slots ( -- seq )
- [ (parse-tuple-slots) ] { } make ;
+: parse-tuple-slots ( -- )
+ scan parse-slot-name [ parse-tuple-slots ] when ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
- { "<" [ scan-word parse-tuple-slots ] }
- [ >r tuple parse-tuple-slots r> prefix ]
+ { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
+ [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
} case 3dup check-slot-shadowing ;
USING: generic help.markup help.syntax kernel
classes.tuple.private classes slots quotations words arrays
-generic.standard sequences definitions compiler.units ;
+generic.standard sequences definitions compiler.units
+growable vectors sbufs ;
IN: classes.tuple
ARTICLE: "parametrized-constructors" "Parameterized constructors"
}
"Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ;
+ARTICLE: "protocol-slots" "Protocol slots"
+"A " { $emphasis "protocol slot" } " is one which is assumed to exist by the implementation of a class, without being defined on the class itself. The burden is on subclasses (or mixin instances) to provide this slot."
+$nl
+"Protocol slots are defined using a parsing word:"
+{ $subsection POSTPONE: SLOT: }
+"Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass."
+$nl
+"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots:"
+{ $snippet "SLOT: length" "SLOT: underlying" }
+"An alternate approach would be to define " { $link growable } " as a tuple class with these two slots, and have other classes subclass it as required. However, this rules out subclasses defining these slots with custom type declarations."
+$nl
+"For example, compare the definitions of the " { $link sbuf } " class,"
+{ $code
+ "TUPLE: sbuf"
+ "{ \"underlying\" string }"
+ "{ \"length\" array-capacity } ;"
+ ""
+ "INSTANCE: sbuf growable"
+}
+"with that of the " { $link vector } " class:"
+{ $code
+ "TUPLE: vector"
+ "{ \"underlying\" array }"
+ "{ \"length\" array-capacity } ;"
+ ""
+ "INSTANCE: vector growable"
+} ;
+
ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots."
{ $subsection "tuple-examples" }
{ $subsection "tuple-constructors" }
"Expressing relationships through the object system:"
{ $subsection "tuple-subclassing" }
+"Protocol slots:"
+{ $subsection "protocol-slots" }
"Introspection:"
{ $subsection "tuple-introspection" }
"Tuple classes can be redefined; this updates existing instances:"
[ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ]
-[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
+[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word name>> ] unit-test
TUPLE: size-test a b c d ;
[ t ] [
T{ size-test } tuple-size
- size-test tuple-layout layout-size =
+ size-test tuple-layout size>> =
] unit-test
GENERIC: <yo-momma>
[ laptop ] [
"laptop" get 1 slot
- dup layout-echelon swap
- layout-superclasses nth
+ dup echelon>> swap
+ superclasses>> nth
] unit-test
[ "TUPLE: laptop < computer battery ;" ] [
check-tuple-class "layout" word-prop ;
: tuple-size ( tuple -- size )
- 1 slot layout-size ; inline
+ 1 slot size>> ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ;
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
- layout-class prefix ;
+ class>> prefix ;
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
#! 5 slot == layout-echelon
[
[ 1 slot dup 5 slot ] %
- dup tuple-layout layout-echelon ,
+ dup tuple-layout echelon>> ,
[ fixnum>= ] %
[
- dup tuple-layout layout-echelon ,
+ dup tuple-layout echelon>> ,
[ swap 4 slot array-nth ] %
literalize ,
[ eq? ] %
[ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs )
- over superclass-size 2 + simple-slots ;
+ over superclass-size 2 + make-slots deprecated-slots ;
: define-tuple-slots ( class -- )
dup dup "slot-names" word-prop generate-tuple-slots
M: tuple-class reset-class
[
- dup "slot-names" word-prop [
+ dup "slots" word-prop [
+ name>>
[ reader-word method forget ]
[ writer-word method forget ] 2bi
] with each
] [
[ call-next-method ]
- [ { "layout" "slots" } reset-props ]
+ [ { "layout" "slots" "slot-names" } reset-props ]
bi
] bi ;
[ "two" ] [ 2 case-test-1 ] unit-test
! Interpreted
-[ "two" ] [ 2 \ case-test-1 word-def call ] unit-test
+[ "two" ] [ 2 \ case-test-1 def>> call ] unit-test
[ "x" case-test-1 ] must-fail
[ 25 ] [ 5 case-test-2 ] unit-test
! Interpreted
-[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test
+[ 25 ] [ 5 \ case-test-2 def>> call ] unit-test
: case-test-3 ( obj -- obj' )
{
] unit-test
! Interpreted
-[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
+[ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test
[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays sequences sequences.private math.private
+USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting words sets math.order ;
IN: combinators
dupd first dup word? [
execute
] [
- dup wrapper? [ wrapped ] when
+ dup wrapper? [ wrapped>> ] when
] if =
] [ quotation? ] if
] find nip ;
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
-: xword-def ( word -- def ) word-def [ { fixnum } declare ] prepend ;
+: xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
: hey ( -- ) ;
: there ( -- ) hey ;
-[ t ] [ \ hey compiled? ] unit-test
-[ t ] [ \ there compiled? ] unit-test
+[ t ] [ \ hey compiled>> ] unit-test
+[ t ] [ \ there compiled>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ hey compiled? ] unit-test
-[ f ] [ \ there compiled? ] unit-test
+[ f ] [ \ hey compiled>> ] unit-test
+[ f ] [ \ there compiled>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
-[ t ] [ \ there compiled? ] unit-test
+[ t ] [ \ there compiled>> ] unit-test
! Just changing the stack effect didn't mark a word for recompilation
DEFER: change-effect
: bad ( -- ) good ;
: ugly ( -- ) bad ;
-[ t ] [ \ good compiled? ] unit-test
-[ t ] [ \ bad compiled? ] unit-test
-[ t ] [ \ ugly compiled? ] unit-test
+[ t ] [ \ good compiled>> ] unit-test
+[ t ] [ \ bad compiled>> ] unit-test
+[ t ] [ \ ugly compiled>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ good compiled? ] unit-test
-[ f ] [ \ bad compiled? ] unit-test
-[ f ] [ \ ugly compiled? ] unit-test
+[ f ] [ \ good compiled>> ] unit-test
+[ f ] [ \ bad compiled>> ] unit-test
+[ f ] [ \ ugly compiled>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
-[ t ] [ \ good compiled? ] unit-test
-[ t ] [ \ bad compiled? ] unit-test
-[ t ] [ \ ugly compiled? ] unit-test
+[ t ] [ \ good compiled>> ] unit-test
+[ t ] [ \ bad compiled>> ] unit-test
+[ t ] [ \ ugly compiled>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled? ] unit-test
+[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled? ] unit-test
+[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
- "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
+ "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
] unit-test
] times
[ dup float+ ]
} cleave ;
-[ t ] [ \ float-spill-bug compiled? ] unit-test
+[ t ] [ \ float-spill-bug compiled>> ] unit-test
! Regression
: dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
-[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
+[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations assocs namespaces sequences words
-vocabs definitions hashtables init sets ;
+USING: accessors kernel continuations assocs namespaces
+sequences words vocabs definitions hashtables init sets ;
IN: compiler.units
SYMBOL: old-definitions
: changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-filter
- [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
+ [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
: updated-definitions ( -- assoc )
H{ } clone
[ 1 3 2 ] [ bar ] unit-test
-[ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test
+[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test
} define-intrinsic
\ <tuple> [
- tuple "layout" get layout-size 2 + cells %allot
+ tuple "layout" get size>> 2 + cells %allot
! Store layout
"layout" get 12 load-indirect
12 11 cell STW
! Zero out the rest of the tuple
f v>operand 12 LI
- "layout" get layout-size [ 12 11 rot 2 + cells STW ] each
+ "layout" get size>> [ 12 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] H{
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
- dup slot-spec-type swap slot-spec-offset 2array
+ [ type>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays cpu.x86.assembler
+USING: accessors alien alien.accessors arrays cpu.x86.assembler
cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
kernel.private math math.private namespaces quotations sequences
words generic byte-arrays hashtables hashtables.private
} define-intrinsic
\ <tuple> [
- tuple "layout" get layout-size 2 + cells [
+ tuple "layout" get size>> 2 + cells [
! Store layout
"layout" get "scratch" get load-literal
1 object@ "scratch" operand MOV
! Zero out the rest of the tuple
- "layout" get layout-size [
+ "layout" get size>> [
2 + object@ f v>operand MOV
] each
! Store tagged ptr in reg
GENERIC: (stack-picture) ( obj -- str )
M: string (stack-picture) ;
-M: word (stack-picture) word-name ;
+M: word (stack-picture) name>> ;
M: integer (stack-picture) drop "object" ;
: stack-picture ( seq -- string )
M: word stack-effect
{ "declared-effect" "inferred-effect" }
- swap word-props [ at ] curry map [ ] find nip ;
+ swap props>> [ at ] curry map [ ] find nip ;
M: effect clone
[ in>> clone ] [ out>> clone ] bi <effect> ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: push-4 ( value vector -- )
- [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
>r add-literal r> rt-xt rel-fixup ;
: rel-primitive ( word class -- )
- >r word-def first r> rt-primitive rel-fixup ;
+ >r def>> first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes combinators cpu.architecture
+USING: accessors arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer
} cond ;
: maybe-compile ( word -- )
- dup compiled? [ drop ] [ queue-compile ] if ;
+ dup compiled>> [ drop ] [ queue-compile ] if ;
SYMBOL: compiling-word
[ t ] [
\ / usage [ word? ] filter
- [ word-name "generic-forget-test-1/integer" = ] contains?
+ [ name>> "generic-forget-test-1/integer" = ] contains?
] unit-test
[ ] [
[ f ] [
\ / usage [ word? ] filter
- [ word-name "generic-forget-test-1/integer" = ] contains?
+ [ name>> "generic-forget-test-1/integer" = ] contains?
] unit-test
GENERIC: generic-forget-test-2 ( a b -- c )
[ t ] [
\ = usage [ word? ] filter
- [ word-name "generic-forget-test-2/sequence" = ] contains?
+ [ name>> "generic-forget-test-2/sequence" = ] contains?
] unit-test
[ ] [
[ f ] [
\ = usage [ word? ] filter
- [ word-name "generic-forget-test-2/sequence" = ] contains?
+ [ name>> "generic-forget-test-2/sequence" = ] contains?
] unit-test
GENERIC: generic-forget-test-3 ( a -- b )
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: words kernel sequences namespaces assocs hashtables
-definitions kernel.private classes classes.private
+USING: accessors words kernel sequences namespaces assocs
+hashtables definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators
sets ;
IN: generic
3tri ; inline
: method-word-name ( class word -- string )
- word-name "/" rot word-name 3append ;
+ [ name>> ] bi@ "=>" swap 3append ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
check-method
[ method-word-props ] 2keep
method-word-name f <word>
- [ set-word-props ] keep ;
+ swap >>props ;
: with-implementors ( class generic quot -- )
[ swap implementors-map get at ] dip call ; inline
TUPLE: tuple-dispatch-engine echelons ;
: push-echelon ( class method assoc -- )
- >r swap dup "layout" word-prop layout-echelon r>
+ >r swap dup "layout" word-prop echelon>> r>
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
] [ ] make ;
: engine-word-name ( -- string )
- generic get word-name "/tuple-dispatch-engine" append ;
+ generic get name>> "/tuple-dispatch-engine" append ;
PREDICATE: engine-word < word
"tuple-dispatch-generic" word-prop generic? ;
[ ] [ \ no-stack-effect-decl see ] unit-test
-[ ] [ \ no-stack-effect-decl word-def . ] unit-test
+[ ] [ \ no-stack-effect-decl def>> . ] unit-test
! Cross-referencing with generic words
TUPLE: xref-tuple-1 ;
$nl
"There is a resizable sequence mixin:"
{ $subsection growable }
-"This mixin implements the sequence protocol in terms of a growable protocol:"
-{ $subsection underlying }
-{ $subsection set-underlying }
-{ $subsection set-fill }
+"This mixin implements the sequence protocol by assuming the object has two specific slots:"
+{ $list
+ { { $snippet "length" } " - the fill pointer (number of occupied elements in the underlying storage)" }
+ { { $snippet "underlying" } " - the underlying storage" }
+}
"The underlying sequence must implement a generic word:"
{ $subsection resize }
-{ $link "vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ;
+{ $link "vectors" } ", " { $link "byte-vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ;
ABOUT: "growable"
-HELP: set-fill
-{ $values { "n" "a new fill pointer" } { "seq" growable } }
-{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." }
-{ $side-effects "seq" }
-{ $warning "This word is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
-
-HELP: underlying
-{ $values { "seq" growable } { "underlying" "the underlying sequence" } }
-{ $contract "Outputs the underlying storage of a resizable sequence." } ;
-
-HELP: set-underlying
-{ $values { "underlying" sequence } { "seq" growable } }
-{ $contract "Modifies the underlying storage of a resizable sequence." }
-{ $warning "This word is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
-
HELP: capacity
{ $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } }
{ $description "Outputs the number of elements the sequence can hold without growing." } ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
! Some low-level code used by vectors and string buffers.
-USING: kernel kernel.private math math.private
+USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
IN: growable
MIXIN: growable
-GENERIC: underlying ( seq -- underlying )
-GENERIC: set-underlying ( underlying seq -- )
-GENERIC: set-fill ( n seq -- )
-M: growable nth-unsafe underlying nth-unsafe ;
+SLOT: length
+SLOT: underlying
-M: growable set-nth-unsafe underlying set-nth-unsafe ;
+M: growable length length>> ;
+M: growable nth-unsafe underlying>> nth-unsafe ;
+M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
-: capacity ( seq -- n ) underlying length ; inline
+: capacity ( seq -- n ) underlying>> length ; inline
: expand ( len seq -- )
- [ underlying resize ] keep set-underlying ; inline
+ [ resize ] change-underlying drop ; inline
: contract ( len seq -- )
[ length ] keep
] [
2dup capacity > [ 2dup expand ] when
] if
- >r >fixnum r> set-fill ;
+ swap >fixnum >>length drop ;
: new-size ( old -- new ) 1+ 3 * ; inline
2dup length >= [
2dup capacity >= [ over new-size over expand ] when
>r >fixnum r>
- 2dup >r 1 fixnum+fast r> set-fill
+ 2dup swap 1 fixnum+fast >>length drop
] [
>r >fixnum r>
] if ; inline
M: growable set-nth ensure set-nth-unsafe ;
-M: growable clone ( seq -- newseq )
- (clone) dup underlying clone over set-underlying ;
+M: growable clone (clone) [ clone ] change-underlying ;
M: growable lengthen ( n seq -- )
2dup length > [
2dup capacity > [ over new-size over expand ] when
- 2dup >r >fixnum r> set-fill
+ 2dup swap >fixnum >>length drop
] when 2drop ;
INSTANCE: growable sequence
$nl
"There are two special objects: the " { $link ((tombstone)) } " marker and the " { $link ((empty)) } " marker. Neither of these markers can be used as hashtable keys."
$nl
-"The " { $link hash-count } " slot is the number of entries including deleted entries, and " { $link hash-deleted } " is the number of deleted entries."
+"The " { $snippet "count" } " slot is the number of entries including deleted entries, and " { $snippet "deleted" } " is the number of deleted entries."
{ $subsection <hash-array> }
{ $subsection set-nth-pair }
"If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:"
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel kernel.private slots.private math assocs
-math.private sequences sequences.private vectors grouping ;
+USING: accessors arrays kernel kernel.private slots.private math
+assocs math.private sequences sequences.private vectors grouping ;
IN: hashtables
+TUPLE: hashtable
+{ "count" array-capacity }
+{ "deleted" array-capacity }
+{ "array" array } ;
+
<PRIVATE
: wrap ( i array -- n )
] if ; inline
: key@ ( key hash -- array n ? )
- hash-array 2dup hash@ (key@) ; inline
+ array>> 2dup hash@ (key@) ; inline
: <hash-array> ( n -- array )
1+ next-power-of-2 4 * ((empty)) <array> ; inline
: init-hash ( hash -- )
- 0 over set-hash-count 0 swap set-hash-deleted ;
+ 0 >>count 0 >>deleted drop ; inline
: reset-hash ( n hash -- )
- swap <hash-array> over set-hash-array init-hash ;
+ swap <hash-array> >>array init-hash ;
: (new-key@) ( key keys i -- keys n empty? )
3dup swap array-nth dup ((empty)) eq? [
] if ; inline
: new-key@ ( key hash -- array n empty? )
- hash-array 2dup hash@ (new-key@) ; inline
+ array>> 2dup hash@ (new-key@) ; inline
: set-nth-pair ( value key seq n -- )
2 fixnum+fast [ set-slot ] 2keep
1 fixnum+fast set-slot ; inline
: hash-count+ ( hash -- )
- dup hash-count 1+ swap set-hash-count ; inline
+ [ 1+ ] change-count drop ; inline
: hash-deleted+ ( hash -- )
- dup hash-deleted 1+ swap set-hash-deleted ; inline
+ [ 1+ ] change-deleted drop ; inline
: (set-hash) ( value key hash -- new? )
2dup new-key@
swap [ swapd (set-hash) drop ] curry assoc-each ;
: hash-large? ( hash -- ? )
- [ hash-count 3 fixnum*fast ]
- [ hash-array array-capacity ] bi > ;
+ [ count>> 3 fixnum*fast ]
+ [ array>> array-capacity ] bi > ;
: hash-stale? ( hash -- ? )
- [ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
+ [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ;
: grow-hash ( hash -- )
[ dup >alist swap assoc-size 1+ ] keep
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
M: hashtable clear-assoc ( hash -- )
- dup init-hash hash-array [ drop ((empty)) ] change-each ;
+ [ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ;
M: hashtable delete-at ( key hash -- )
tuck key@ [
] if ;
M: hashtable assoc-size ( hash -- n )
- dup hash-count swap hash-deleted - ;
+ [ count>> ] [ deleted>> ] bi - ;
: rehash ( hash -- )
- dup >alist
- over hash-array length ((empty)) <array> pick set-hash-array
- 0 pick set-hash-count
- 0 pick set-hash-deleted
- (rehash) ;
+ dup >alist >r
+ dup clear-assoc
+ r> (rehash) ;
M: hashtable set-at ( value key hash -- )
dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ;
2 <hashtable> [ set-at ] keep ;
M: hashtable >alist
- hash-array 2 <groups> [ first tombstone? not ] filter ;
+ array>> 2 <groups> [ first tombstone? not ] filter ;
M: hashtable clone
- (clone) dup hash-array clone over set-hash-array ;
+ (clone) [ clone ] change-array ;
M: hashtable equal?
over hashtable? [
M: object apply-object apply-literal ;
M: wrapper apply-object
- wrapped dup +called+ depends-on apply-literal ;
+ wrapped>> dup +called+ depends-on apply-literal ;
: terminate ( -- )
terminated? on #terminate node, ;
{ [ dup inline? ] [ drop f ] }
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
- [ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ]
+ [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
} cond ;
: ?missing-effect ( word -- )
[
init-inference
dependencies off
- dup word-def over dup infer-quot-recursive
+ dup def>> over dup infer-quot-recursive
end-infer
finish-word
current-effect
: inline-block ( word -- #label data )
[
copy-inference nest-node
- [ word-def ] [ <inlined-block> ] bi
+ [ def>> ] [ <inlined-block> ] bi
[ infer-quot-recursive ] 2keep
#label unnest-node
dup collect-label-info
[ dup V{ } eq? [ foo ] when ] dup second dup push define
] with-compilation-unit
- \ blah word-def dataflow optimize drop
+ \ blah def>> dataflow optimize drop
] unit-test
GENERIC: detect-fx ( n -- n )
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
-[ \ #4 word-def infer ] must-fail
+[ \ #4 def>> infer ] must-fail
[ [ #1 ] infer ] must-fail
! Similar
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays bit-arrays byte-arrays
+USING: accessors alien alien.accessors arrays bit-arrays byte-arrays
classes sequences.private continuations.private effects
float-arrays generic hashtables hashtables.private
inference.state inference.backend inference.dataflow io
! Variadic tuple constructor
\ <tuple-boa> [
\ <tuple-boa>
- peek-d value-literal layout-size { tuple } <effect>
+ peek-d value-literal size>> { tuple } <effect>
make-call-node
] "infer" set-word-prop
[ 1 2 3 ] [ 1 2 3 <color> cleave-test ] unit-test
-[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test word-def call ] unit-test
+[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test def>> call ] unit-test
: 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ;
[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
-[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test
+[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test def>> call ] unit-test
: spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ;
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
-[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
+[ 16 -3 1/6 ] [ 4 3 6 \ spread-test def>> call ] unit-test
[ fixnum instance? ] must-infer
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic hashtables io kernel assocs math
+USING: accessors arrays generic hashtables io kernel assocs math
namespaces prettyprint sequences strings io.styles vectors words
quotations mirrors splitting math.parser classes vocabs refs
sets sorting ;
GENERIC: summary ( object -- string )
: object-summary ( object -- string )
- class word-name " instance" append ;
+ class name>> " instance" append ;
M: object summary object-summary ;
M: sequence summary
[
- dup class word-name %
+ dup class name>> %
" with " %
length #
" elements" %
M: assoc summary
[
- dup class word-name %
+ dup class name>> %
" with " %
assoc-size #
" entries" %
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel math namespaces sequences sbufs strings
-generic splitting growable continuations destructors
-io.streams.plain io.encodings math.order ;
+USING: accessors io kernel math namespaces sequences sbufs
+strings generic splitting continuations destructors
+io.streams.plain io.encodings math.order growable ;
IN: io.streams.string
M: growable dispose drop ;
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
: harden-as ( seq growble-exemplar -- newseq )
- underlying like ;
+ underlying>> like ;
: growable-read-until ( growable n -- str )
>fixnum dupd tail-slice swap harden-as dup reverse-here ;
{ $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." }
{ $examples
"This example outputs text in all three styles:"
- { $code "{ plain bold italic bold-italic }\n[ [ word-name ] keep font-style associate format nl ] each" }
+ { $code "{ plain bold italic bold-italic }\n[ [ name>> ] keep font-style associate format nl ] each" }
} ;
HELP: presented
PRIVATE>
! Deprecated
+GENERIC: delegate ( obj -- delegate )
+
+M: tuple delegate 2 slot ;
+
M: object delegate drop f ;
+GENERIC: set-delegate ( delegate tuple -- )
+
+M: tuple set-delegate 2 set-slot ;
+
GENERIC# get-slots 1 ( tuple slots -- ... )
GENERIC# set-slots 1 ( ... tuple slots -- )
GENERIC: expected>string ( obj -- str )
M: f expected>string drop "end of input" ;
-M: word expected>string word-name ;
+M: word expected>string name>> ;
M: string expected>string ;
M: unexpected error.
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
-[ t ] [ \ foo compiled? ] unit-test
+[ t ] [ \ foo compiled>> ] unit-test
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
-HELP: real-part ( z -- x )
+HELP: real-part
{ $values { "z" number } { "x" real } }
{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } ;
-HELP: imaginary-part ( z -- y )
+HELP: imaginary-part
{ $values { "z" number } { "y" real } }
{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ;
GENERIC: >integer ( x -- n ) foldable
GENERIC: >float ( x -- y ) foldable
+GENERIC: numerator ( a/b -- a )
+GENERIC: denominator ( a/b -- b )
+
+GENERIC: real-part ( z -- x )
+GENERIC: imaginary-part ( z -- y )
+
MATH: number= ( x y -- ? ) foldable
M: object number= 2drop f ;
M: mirror set-at ( val key mirror -- )
[ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
- dup writer>> [
- nip offset>> set-slot
- ] [
+ dup read-only>> [
drop immutable-slot
+ ] [
+ nip offset>> set-slot
] if
] [
drop no-such-slot
{
[ swapd * -rot p2 +@ ]
[ 2swap [ swapd * -rot p2 +@ ] 2keep ]
- } \ regression-1 word-def kill-set [ member? ] curry map
+ } \ regression-1 def>> kill-set [ member? ] curry map
] unit-test
: regression-2 ( x y -- x.y )
] with assoc-each
]
}
- \ regression-2 word-def kill-set
+ \ regression-2 def>> kill-set
[ member? ] curry map
] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs inference inference.class
+USING: accessors arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes classes.algebra generic.math
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! inline
- [ dup dup set word-def (flat-length) ]
+ [ dup dup set def>> (flat-length) ]
} cond ;
: (flat-length) ( seq -- n )
] map sum ;
: flat-length ( seq -- n )
- [ word-def (flat-length) ] with-scope ;
+ [ def>> (flat-length) ] with-scope ;
! Single dispatch method inlining optimization
: node-class# ( node n -- class )
: splice-word-def ( #call word -- node )
dup +inlined+ depends-on
- dup word-def swap 1array splice-quot ;
+ dup def>> swap 1array splice-quot ;
: optimistic-inline ( #call -- node )
dup node-param over node-history memq? [
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
-USING: alien arrays generic hashtables inference.dataflow
+USING: accessors alien arrays generic hashtables inference.dataflow
inference.class kernel assocs math math.order math.private
kernel.private sequences words parser vectors strings sbufs io
namespaces assocs quotations sequences.private io.binary
{ <tuple> <tuple-boa> } [
[
dup node-in-d peek node-literal
- dup tuple-layout? [ layout-class ] [ drop tuple ] if
+ dup tuple-layout? [ class>> ] [ drop tuple ] if
1array f
] "output-classes" set-word-prop
] each
alien-signed-8
alien-unsigned-8
} [
- dup word-name {
+ dup name>> {
{
[ "alien-signed-" ?head ]
[ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private math math.private words
+USING: accessors kernel kernel.private math math.private words
sequences parser namespaces assocs quotations arrays
generic generic.math hashtables effects ;
IN: optimizer.math.partial
<<
: integer-op-combinator ( triple -- word )
[
- [ second word-name % "-" % ]
- [ third word-name % "-op" % ]
+ [ second name>> % "-" % ]
+ [ third name>> % "-op" % ]
bi
] "" make in get lookup ;
: integer-op-word ( triple fix-word big-word -- word )
[
drop
- word-name "fast" tail? >r
- [ "-" % ] [ word-name % ] interleave
+ name>> "fast" tail? >r
+ [ "-" % ] [ name>> % ] interleave
r> [ "-fast" % ] when
] "" make in get create ;
{ fixnum bignum float }
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
[ nip ] assoc-filter
- [ word-def peek ] assoc-map % ;
+ [ def>> peek ] assoc-map % ;
SYMBOL: math-ops
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
-[ t ] [ \ xyz compiled? ] unit-test
+[ t ] [ \ xyz compiled>> ] unit-test
! Test predicate inlining
: pred-test-1
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage compiled? ] unit-test
+[ t ] [ \ breakage compiled>> ] unit-test
[ breakage ] must-fail
! regression
! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ;
-[ t ] [ \ <tuple>-regression compiled? ] unit-test
+[ t ] [ \ <tuple>-regression compiled>> ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
-[ t ] [ \ node-successor-f-bug compiled? ] unit-test
+[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
[ ] [ [ new ] dataflow optimize drop ] unit-test
] if
] if ;
-[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
+[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
! Inlining all of the above should only take two passes
[ { t f } ] [
- \ generic-inline-test-1 word-def dataflow
+ \ generic-inline-test-1 def>> dataflow
[ optimize-1 , optimize-1 , drop ] { } make
] unit-test
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
-[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
+[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
DEFER: recursive-inline-hang-3
! Copyright (C) 2006, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays generic hashtables kernel kernel.private math\r
-namespaces sequences vectors words strings layouts combinators\r
-sequences.private classes generic.standard\r
+USING: accessors arrays generic hashtables kernel kernel.private\r
+math namespaces sequences vectors words strings layouts\r
+combinators sequences.private classes generic.standard\r
generic.standard.engines assocs ;\r
IN: optimizer.specializers\r
\r
] [ drop f ] if ;\r
\r
: specialized-def ( word -- quot )\r
- dup word-def swap {\r
+ dup def>> swap {\r
{ [ dup standard-method? ] [ specialize-method ] }\r
{\r
[ dup "specializer" word-prop ]\r
dup no-word-error boa
swap words-named [ forward-reference? not ] filter
word-restarts throw-restarts
- dup word-vocabulary (use+) ;
+ dup vocabulary>> (use+) ;
: check-forward ( str word -- word/f )
dup forward-reference? [
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays byte-vectors bit-arrays generic
+USING: accessors arrays byte-arrays byte-vectors bit-arrays generic
hashtables io assocs kernel math namespaces sequences strings
sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
] keep ;
: word-name* ( word -- str )
- word-name "( no name )" or ;
+ name>> "( no name )" or ;
: pprint-word ( word -- )
dup record-vocab
: check-recursion ( obj quot -- )
nesting-limit? [
drop
- "~" over class word-name "~" 3append
+ "~" over class name>> "~" 3append
swap present-text
] [
over recursion-check get memq? [
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
M: tuple >pprint-sequence tuple>array ;
-M: wrapper >pprint-sequence wrapped 1array ;
+M: wrapper >pprint-sequence wrapped>> 1array ;
M: callstack >pprint-sequence callstack>array ;
GENERIC: pprint-narrow? ( obj -- ? )
M: object pprint* pprint-object ;
M: curry pprint*
- dup curry-quot callable? [ pprint-object ] [
+ dup quot>> callable? [ pprint-object ] [
"( invalid curry )" swap present-text
] if ;
M: compose pprint*
- dup compose-first over compose-second [ callable? ] both?
+ dup [ first>> callable? ] [ second>> callable? ] bi and
[ pprint-object ] [
"( invalid compose )" swap present-text
] if ;
M: wrapper pprint*
- dup wrapped word? [
- <block \ \ pprint-word wrapped pprint-word block>
+ dup wrapped>> word? [
+ <block \ \ pprint-word wrapped>> pprint-word block>
] [
pprint-object
] if ;
"word-style" set-word-prop
: remove-step-into ( word -- )
- building get dup empty? [ drop ] [ nip pop wrapped ] if , ;
+ building get dup empty? [ drop ] [ nip pop wrapped>> ] if , ;
: (remove-breakpoints) ( quot -- newquot )
[
[ H{ { font-style italic } } styled-text ] when* ;
: seeing-word ( word -- )
- word-vocabulary pprinter-in set ;
+ vocabulary>> pprinter-in set ;
: definer. ( defspec -- )
definer drop pprint-word ;
M: object declarations. drop ;
: declaration. ( word prop -- )
- tuck word-name word-prop [ pprint-word ] [ drop ] if ;
+ tuck name>> word-prop [ pprint-word ] [ drop ] if ;
M: word declarations.
{
: <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
: record-vocab ( word -- )
- word-vocabulary [ pprinter-use get conjoin ] when* ;
+ vocabulary>> [ pprinter-use get conjoin ] when* ;
! Utility words
: line-limit? ( -- ? )
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays sequences sequences.private
+USING: accessors arrays sequences sequences.private
kernel kernel.private math assocs quotations.private
slots.private ;
IN: quotations
M: compose call dup 3 slot swap 4 slot slip call ;
M: wrapper equal?
- over wrapper? [ [ wrapped ] bi@ = ] [ 2drop f ] if ;
+ over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;
UNION: callable quotation curry compose ;
M: callable equal?
over callable? [ sequence= ] [ 2drop f ] if ;
-M: quotation length quotation-array length ;
+M: quotation length array>> length ;
-M: quotation nth-unsafe quotation-array nth-unsafe ;
+M: quotation nth-unsafe array>> nth-unsafe ;
: >quotation ( seq -- quot )
>array array>quotation ; inline
M: wrapper literalize <wrapper> ;
-M: curry length curry-quot length 1+ ;
+M: curry length quot>> length 1+ ;
M: curry nth
- over zero? [
- nip curry-obj literalize
- ] [
- >r 1- r> curry-quot nth
- ] if ;
+ over zero? [ nip obj>> literalize ] [ >r 1- r> quot>> nth ] if ;
INSTANCE: curry immutable-sequence
M: compose length
- [ compose-first length ]
- [ compose-second length ] bi + ;
+ [ first>> length ] [ second>> length ] bi + ;
-M: compose virtual-seq compose-first ;
+M: compose virtual-seq first>> ;
M: compose virtual@
- 2dup compose-first length < [
- compose-first
+ 2dup first>> length < [
+ first>>
] [
- [ compose-first length - ] [ compose-second ] bi
+ [ first>> length - ] [ second>> ] bi
] if ;
INSTANCE: compose virtual-sequence
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math strings sequences.private sequences strings
-growable strings.private ;
+USING: accessors kernel math strings sequences.private sequences
+strings growable strings.private ;
IN: sbufs
+TUPLE: sbuf
+{ "underlying" string }
+{ "length" array-capacity } ;
+
<PRIVATE
: string>sbuf ( string length -- sbuf )
: <sbuf> ( n -- sbuf ) 0 <string> 0 string>sbuf ; inline
M: sbuf set-nth-unsafe
- underlying >r >r >fixnum r> >fixnum r> set-string-nth ;
+ [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ;
-M: sbuf new-sequence drop [ 0 <string> ] keep >fixnum string>sbuf ;
+M: sbuf new-sequence
+ drop [ 0 <string> ] [ >fixnum ] bi string>sbuf ;
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
M: string like
drop dup string? [
dup sbuf? [
- dup length over underlying length number= [
- underlying dup reset-string-hashcode
+ dup length over underlying>> length number= [
+ underlying>> dup reset-string-hashcode
] [
>string
] if
! Copyright (C) 2005, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math namespaces\r
+USING: accessors arrays kernel kernel.private math namespaces\r
sequences strings words effects generic generic.standard\r
classes slots.private combinators slots ;\r
IN: slots.deprecated\r
[ set-reader-props ] 2keep\r
dup slot-spec-offset\r
over slot-spec-reader\r
- rot slot-spec-type reader-quot\r
+ rot slot-spec-class reader-quot\r
define-slot-word\r
] [\r
2drop\r
>r [ swap "set-" % % "-" % % ] "" make r> create ;\r
\r
: (simple-slot-word) ( class name -- class name vocab )\r
- over word-vocabulary >r >r word-name r> r> ;\r
+ over vocabulary>> >r >r name>> r> r> ;\r
\r
: simple-reader-word ( class name -- word )\r
(simple-slot-word) reader-word ;\r
: simple-writer-word ( class name -- word )\r
(simple-slot-word) writer-word ;\r
\r
-: short-slot ( class name # -- spec )\r
- >r object bootstrap-word over r> f f <slot-spec>\r
- 2over simple-reader-word over set-slot-spec-reader\r
- -rot simple-writer-word over set-slot-spec-writer ;\r
-\r
-: long-slot ( spec # -- spec )\r
- >r [ dup array? [ first2 create ] when ] map first4 r>\r
- -rot <slot-spec> ;\r
-\r
-: simple-slots ( class slots base -- specs )\r
- over length [ + ] with map [\r
- {\r
- { [ over not ] [ 2drop f ] }\r
- { [ over string? ] [ >r dupd r> short-slot ] }\r
- { [ over array? ] [ long-slot ] }\r
- } cond\r
- ] 2map sift nip ;\r
-\r
-: slot-of-reader ( reader specs -- spec/f )\r
- [ slot-spec-reader eq? ] with find nip ;\r
-\r
-: slot-of-writer ( writer specs -- spec/f )\r
- [ slot-spec-writer eq? ] with find nip ;\r
+: deprecated-slots ( class slot-specs -- slot-specs' )\r
+ [\r
+ 2dup name>> simple-reader-word >>reader\r
+ 2dup name>> simple-writer-word >>writer\r
+ ] map nip ;\r
$nl
"The slots of a slot specification are:"
{ $list
- { { $link slot-spec-type } " - a " { $link class } " declaring the set of possible values for the slot." }
- { { $link slot-spec-name } " - a " { $link string } " identifying the slot." }
- { { $link slot-spec-offset } " - an " { $link integer } " offset specifying where the slot value is stored inside instances of the relevant class. This is an implementation detail." }
- { { $link slot-spec-reader } " - a " { $link word } " for reading the value of this slot." }
- { { $link slot-spec-writer } " - a " { $link word } " for writing the value of this slot." }
+ { { $snippet "name" } " - a " { $link string } " identifying the slot." }
+ { { $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." }
} } ;
HELP: define-typecheck
}
"It checks if the top of the stack is an instance of " { $snippet "class" } ", and if so, executes the quotation. Delegation is respected."
}
-{ $notes "This word is used internally to wrap low-level code that does not do type-checking in safe user-visible words. For example, see how " { $link word-name } " is implemented." } ;
+{ $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 } }
--- /dev/null
+IN: slots.tests
+USING: math accessors slots strings generic.standard kernel tools.test ;
+
+TUPLE: r/w-test foo ;
+
+TUPLE: r/o-test { "foo" read-only: t } ;
+
+[ r/o-test new 123 >>foo ] [ no-method? ] must-fail-with
+
+TUPLE: decl-test { "foo" integer } ;
+
+[ decl-test new 1.0 >>foo ] [ bad-slot-value? ] must-fail-with
+
+TUPLE: hello length ;
+
+[ 3 ] [ "xyz" length>> ] unit-test
+
+[ "xyz" 4 >>length ] [ no-method? ] must-fail-with
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math namespaces
sequences strings words effects generic generic.standard
-classes slots.private combinators accessors ;
+classes slots.private combinators accessors words ;
IN: slots
-TUPLE: slot-spec type name offset reader writer ;
+TUPLE: slot-spec name offset class initial read-only reader writer ;
-C: <slot-spec> slot-spec
+: <slot-spec> ( -- slot-spec )
+ slot-spec new
+ object bootstrap-word >>class ;
: define-typecheck ( class generic quot -- )
[
create-method
] dip define ;
-: define-slot-word ( class slot word quot -- )
+: define-slot-word ( class offset word quot -- )
rot >fixnum prefix define-typecheck ;
+: create-accessor ( name effect -- word )
+ >r "accessors" create dup r>
+ "declared-effect" set-word-prop ;
+
: reader-quot ( decl -- quot )
[
\ slot ,
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
-: create-accessor ( name effect -- word )
- >r "accessors" create dup r>
- "declared-effect" set-word-prop ;
-
: reader-word ( name -- word )
">>" append (( object -- value )) create-accessor ;
-: define-reader ( class slot name decl -- )
- [ reader-word ] dip reader-quot define-slot-word ;
+: define-reader ( class slot-spec -- )
+ [ offset>> ]
+ [ name>> reader-word ]
+ [ class>> reader-quot ]
+ tri define-slot-word ;
: writer-word ( name -- word )
"(>>" swap ")" 3append (( value object -- )) create-accessor ;
] if
] [ ] make ;
-: define-writer ( class slot name decl -- )
- [ writer-word ] dip writer-quot define-slot-word ;
+: define-writer ( class slot-spec -- )
+ [ offset>> ]
+ [ name>> writer-word ]
+ [ class>> writer-quot ]
+ tri define-slot-word ;
: setter-word ( name -- word )
">>" prepend (( object value -- object )) create-accessor ;
-: define-setter ( name -- )
- dup setter-word dup deferred? [
+: define-setter ( slot-spec -- )
+ name>> dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
: changer-word ( name -- word )
"change-" prepend (( object quot -- object )) create-accessor ;
-: define-changer ( name -- )
- dup changer-word dup deferred? [
+: define-changer ( slot-spec -- )
+ name>> dup changer-word dup deferred? [
[
[ over >r >r ] %
over reader-word ,
] [ 2drop ] if ;
: define-slot-methods ( class slot-spec -- )
- {
- [ [ drop ] [ name>> ] bi* define-changer ]
- [ [ drop ] [ name>> ] bi* define-setter ]
- [ [ offset>> ] [ name>> ] [ type>> ] tri define-reader ]
- [ [ offset>> ] [ name>> ] [ type>> ] tri define-writer ]
- } 2cleave ;
+ [ define-reader ]
+ [
+ dup read-only>> [ 2drop ] [
+ [ define-setter drop ]
+ [ define-changer drop ]
+ [ define-writer ]
+ 2tri
+ ] if
+ ] 2bi ;
: define-accessors ( class specs -- )
[ define-slot-methods ] with each ;
+: define-protocol-slot ( name -- )
+ {
+ [ reader-word drop ]
+ [ writer-word drop ]
+ [ setter-word drop ]
+ [ changer-word drop ]
+ } cleave ;
+
+GENERIC: make-slot ( desc -- slot-spec )
+
+M: string make-slot
+ <slot-spec>
+ swap >>name ;
+
+: peel-off-name ( slot-spec array -- slot-spec array )
+ [ first >>name ] [ rest ] bi ; inline
+
+: peel-off-class ( slot-spec array -- slot-spec array )
+ dup empty? [
+ ! We'd use class? here, but during bootstrap, we sometimes
+ ! create slots whose class hasn't been defined yet.
+ dup first name>> ":" tail? not [
+ [ first >>class ] [ rest ] bi
+ ] when
+ ] unless ;
+
+: peel-off-attributes ( slot-spec array -- slot-spec array )
+ dup empty? [
+ unclip {
+ { initial: [ [ first >>initial ] [ rest ] bi ] }
+ { read-only: [ [ first >>read-only ] [ rest ] bi ] }
+ } case
+ ] unless ;
+
+M: array make-slot
+ <slot-spec>
+ swap
+ peel-off-name
+ peel-off-class
+ [ dup empty? not ] [ peel-off-attributes ] [ ] while drop ;
+
+: make-slots ( slots base -- specs )
+ over length [ + ] with map
+ [ [ make-slot ] dip >>offset ] 2map ;
+
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences vectors math.order
-sequences sequences.private growable math.order ;
+USING: accessors arrays kernel math sequences vectors math.order
+sequences sequences.private math.order ;
IN: sorting
DEFER: sort
: merge ( sorted1 sorted2 quot -- result )
>r [ [ <iterator> ] bi@ ] 2keep r>
rot length rot length + <vector>
- [ (merge) ] keep underlying ; inline
+ [ (merge) ] [ underlying>> ] bi ; inline
: conquer ( first second quot -- result )
[ tuck >r >r sort r> r> sort ] keep merge ; inline
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.private sequences kernel.private
+USING: accessors kernel math.private sequences kernel.private
math sequences.private slots.private byte-arrays
alien.accessors ;
IN: strings
nip dup string-hashcode [ ]
[ dup rehash-string string-hashcode ] ?if ;
+M: string length
+ length>> ;
+
M: string nth-unsafe
>r >fixnum r> string-nth ;
>r >fixnum >r >fixnum r> r> set-string-nth ;
M: string clone
- (clone) dup string-aux clone over set-string-aux ;
+ (clone) [ clone ] change-aux ;
M: string resize resize-string ;
HELP: TUPLE:
{ $syntax "TUPLE: class slots... ;" "TUPLE: class < superclass slots ... ;" }
-{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
-{ $description "Defines a new tuple class. The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." } ;
+{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new tuple class."
+$nl
+"The superclass is optional; if left unspecified, it defaults to " { $link tuple } "."
+$nl
+"Slot specifiers take one of the following three forms:"
+{ $list
+ { { $snippet "name" } " - a slot which can hold any object, with no attributes" }
+ { { $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: } "." }
+{ $examples
+ "A simple tuple class:"
+ { $code "TUPLE: color red green blue ;" }
+ "Declaring slots to be integer-valued:"
+ { $code "TUPLE: color" "{ \"red\" integer }" "{ \"green\" integer }" "{ \"blue\" integer } ;" }
+ "An example mixing short and long slot specifiers:"
+ { $code "TUPLE: person" "{ \"age\" integer initial: 0 }" "{ \"department\" string initial: \"Marketing\" }" "manager ;" }
+} ;
+
+HELP: initial:
+{ $syntax "TUPLE: ... { \"slot\" initial: value } ... ;" }
+{ $values { "slot" "a slot name" } { "value" "any literal" } }
+{ $description "Specifies an initial value for a tuple slot." } ;
+
+HELP: read-only:
+{ $syntax "TUPLE: ... { \"slot\" read-only: ? } ... ;" }
+{ $values { "slot" "a slot name" } { "?" "a boolean" } }
+{ $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
+
+HELP: SLOT:
+{ $syntax "SLOT: name" }
+{ $values { "name" "a slot name" } }
+{ $description "Defines a protocol slot; that is, defines the accessor words for a slot named " { $snippet "slot" } " without associating it with any specific tuple." }
+{ $notes
+ "Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass."
+} ;
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }
vocabs float-arrays classes.parser classes.union
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple.parser compiler.units
-combinators debugger effects.parser ;
+combinators debugger effects.parser slots ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
parse-tuple-definition define-tuple-class
] define-syntax
+ "SLOT:" [
+ scan define-protocol-slot
+ ] define-syntax
+
"C:" [
CREATE-WORD
scan-word check-tuple-class
not-in-a-method-error
] if
] define-syntax
+
+ "initial:" "syntax" lookup define-symbol
+
+ "read-only:" "syntax" lookup define-symbol
] with-compilation-unit
USING: arrays kernel math sequences sequences.private growable ;
IN: vectors
+TUPLE: vector
+{ "underlying" array }
+{ "length" array-capacity } ;
+
<PRIVATE
: array>vector ( array length -- vector )
"Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "vocabulary-search" } ")."
{ $subsection create }
{ $subsection create-in }
-{ $subsection lookup }
-"Words can output their name and vocabulary:"
-{ $subsection word-name }
-{ $subsection word-vocabulary } ;
+{ $subsection lookup } ;
ARTICLE: "uninterned-words" "Uninterned words"
"A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "."
"Each word has a hashtable of properties."
{ $subsection word-prop }
{ $subsection set-word-prop }
-{ $subsection word-props }
-{ $subsection set-word-props }
"The stack effect of the above two words is designed so that it is most convenient when " { $snippet "name" } " is a literal pushed on the stack right before executing this word."
$nl
"The following are some of the properties used by the library:"
} ;
ARTICLE: "word.private" "Word implementation details"
-"Primitive definition accessors:"
-{ $subsection word-def }
-{ $subsection set-word-def }
+"The " { $snippet "def" } " slot of a word holds a " { $link quotation } " instance that is called when the word is executed."
+$nl
"An " { $emphasis "XT" } " (execution token) is the machine code address of a word:"
{ $subsection word-xt } ;
ABOUT: "words"
-HELP: compiled? ( word -- ? )
-{ $values { "word" word } { "?" "a boolean" } }
-{ $description "Tests if a word has been compiled." } ;
-
HELP: execute ( word -- )
{ $values { "word" word } }
{ $description "Executes a word." }
{ $example "USING: kernel io words ;" "IN: scratchpad" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
} ;
-HELP: word-props ( word -- props )
-{ $values { "word" word } { "props" "an assoc" } }
-{ $description "Outputs a word's property table." } ;
-
-HELP: set-word-props ( props word -- )
-{ $values { "props" "an assoc" } { "word" word } }
-{ $description "Sets a word's property table." }
-{ $notes "The given assoc must not be a literal, since it will be mutated by future calls to " { $link set-word-prop } "." }
-{ $side-effects "word" } ;
-
-HELP: word-def ( word -- obj )
-{ $values { "word" word } { "obj" object } }
-{ $description "Outputs a word's primitive definition." } ;
-
-HELP: set-word-def ( obj word -- )
-{ $values { "obj" object } { "word" word } }
-{ $description "Sets a word's primitive definition." }
-$low-level-note
-{ $side-effects "word" } ;
-
HELP: deferred
{ $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ;
] with-scope
[ "test-scope" ] [
- "test-scope" "scratchpad" lookup word-name
+ "test-scope" "scratchpad" lookup name>>
] unit-test
[ t ] [ vocabs array? ] unit-test
[ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test
[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test
-[ "test-last" ] [ word word-name ] unit-test
+[ "test-last" ] [ word name>> ] unit-test
! regression
SYMBOL: quot-uses-a
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions graphs assocs kernel kernel.private
-slots.private math namespaces sequences strings vectors sbufs
-quotations assocs hashtables sorting words.private vocabs
-math.order sets ;
+USING: accessors arrays definitions graphs assocs kernel
+kernel.private slots.private math namespaces sequences strings
+vectors sbufs quotations assocs hashtables sorting words.private
+vocabs math.order sets ;
IN: words
: word ( -- word ) \ word get-global ;
M: word execute (execute) ;
M: word <=>
- [ dup word-name swap word-vocabulary 2array ] compare ;
+ [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
M: word definer drop \ : \ ; ;
-M: word definition word-def ;
+M: word definition def>> ;
ERROR: undefined ;
PREDICATE: deferred < word ( obj -- ? )
- word-def [ undefined ] = ;
+ def>> [ undefined ] = ;
M: deferred definer drop \ DEFER: f ;
M: deferred definition drop f ;
PREDICATE: symbol < word ( obj -- ? )
- dup <wrapper> 1array swap word-def sequence= ;
+ [ def>> ] [ [ ] curry ] bi sequence= ;
M: symbol definer drop \ SYMBOL: f ;
M: symbol definition drop f ;
PREDICATE: primitive < word ( obj -- ? )
- word-def [ do-primitive ] tail? ;
+ def>> [ do-primitive ] tail? ;
M: primitive definer drop \ PRIMITIVE: f ;
M: primitive definition drop f ;
-: word-prop ( word name -- value ) swap word-props at ;
+: word-prop ( word name -- value ) swap props>> at ;
-: remove-word-prop ( word name -- )
- swap word-props delete-at ;
+: remove-word-prop ( word name -- ) swap props>> delete-at ;
: set-word-prop ( word value name -- )
over
- [ pick word-props ?set-at swap set-word-props ]
+ [ pick props>> ?set-at >>props drop ]
[ nip remove-word-prop ] if ;
: reset-props ( word seq -- ) [ remove-word-prop ] with each ;
: lookup ( name vocab -- word ) vocab-words at ;
: target-word ( word -- target )
- dup word-name swap word-vocabulary lookup ;
+ [ name>> ] [ vocabulary>> ] bi lookup ;
SYMBOL: bootstrapping?
dup "forgotten" word-prop [
drop f
] [
- word-vocabulary >boolean
+ vocabulary>> >boolean
] if ;
GENERIC: compiled-crossref? ( word -- ? )
M: callable (quot-uses) seq-uses ;
-M: wrapper (quot-uses) >r wrapped r> (quot-uses) ;
+M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ;
: quot-uses ( quot -- assoc )
global [ H{ } clone [ (quot-uses) ] keep ] bind ;
M: word uses ( word -- seq )
- word-def quot-uses keys ;
+ def>> quot-uses keys ;
SYMBOL: compiled-crossref
[ ] like
over unxref
over redefined
- over set-word-def
+ >>def
dup +inlined+ changed-definition
dup crossref? [ dup xref ] when drop ;
gensym dup rot define ;
: reveal ( word -- )
- dup word-name over word-vocabulary dup vocab-words
+ dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
[ ] [ no-vocab ] ?if
set-at ;
M: word forget*
dup "forgotten" word-prop [ drop ] [
[ delete-xref ]
- [ [ word-name ] [ word-vocabulary vocab-words ] bi delete-at ]
+ [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
[ t "forgotten" set-word-prop ]
tri
] if ;
M: word literalize <wrapper> ;
-: ?word-name ( word -- name ) dup word? [ word-name ] when ;
+: ?word-name ( word -- name ) dup word? [ name>> ] when ;
: xref-words ( -- ) all-words [ xref ] each ;
[ call-next-method ] [ f "alias" set-word-prop ] bi ;\r
\r
M: alias stack-effect\r
- word-def first stack-effect ;\r
+ def>> first stack-effect ;\r
\r
: define-alias ( new old -- )\r
[ 1quotation define-inline ]\r
parser accessors ;\r
IN: bit-vectors\r
\r
-TUPLE: bit-vector underlying fill ;\r
-\r
-M: bit-vector underlying underlying>> { bit-array } declare ;\r
-\r
-M: bit-vector set-underlying (>>underlying) ;\r
-\r
-M: bit-vector length fill>> { array-capacity } declare ;\r
-\r
-M: bit-vector set-fill (>>fill) ;\r
+TUPLE: bit-vector\r
+{ "underlying" bit-array }\r
+{ "length" array-capacity } ;\r
\r
<PRIVATE\r
\r
[ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
[ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
[ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
- [ " " write peek-instruction word-name write " " write ] keep
+ [ " " write peek-instruction name>> write " " write ] keep
nl drop ;
: cpu*. ( cpu -- )
dup class db-columns [ ", " 0, ]
[ dup column-name>> 0, 2, ] interleave
from 0,
- class word-name 0,
+ class name>> 0,
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: parser generic kernel classes words slots assocs
+USING: accessors parser generic kernel classes words slots assocs
sequences arrays vectors definitions prettyprint
math hashtables sets macros namespaces ;
IN: delegate
define ;
: change-word-prop ( word prop quot -- )
- rot word-props swap change-at ; inline
+ rot props>> swap change-at ; inline
: register-protocol ( group class quot -- )
rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
ERROR: descriptive-error args underlying word ;\r
\r
M: descriptive-error summary\r
- word>> "The " swap word-name " word encountered an error."\r
+ word>> "The " swap name>> " word encountered an error."\r
3append ;\r
\r
<PRIVATE\r
<ast-number> ;
M: symbol (parse-factor-quotation) ( object -- ast )
- dup >string swap
word-vocabulary <ast-identifier> ;
+ dup >string swap
vocabulary>> <ast-identifier> ;
M: word (parse-factor-quotation) ( object -- ast )
- dup
word-name swap word-vocabulary <ast-identifier> ;
+ dup
name>> swap vocabulary>> <ast-identifier> ;
M: string (parse-factor-quotation) ( object -- ast )
<ast-string> ;
] { } make <ast-hashtable> ;
M: wrapper (parse-factor-quotation) ( object -- ast )
- wrapped dup
word-name swap word-vocabulary <ast-word> ;
+ wrapped dup
name>> swap vocabulary>> <ast-word> ;
GENERIC: fjsc-parse ( object -- ast )
parser accessors ;\r
IN: float-vectors\r
\r
-TUPLE: float-vector underlying fill ;\r
-\r
-M: float-vector underlying underlying>> { float-array } declare ;\r
-\r
-M: float-vector set-underlying (>>underlying) ;\r
-\r
-M: float-vector length fill>> { array-capacity } declare ;\r
-\r
-M: float-vector set-fill (>>fill) ;\r
+TUPLE: float-vector\r
+{ "underlying" float-array }\r
+{ "length" array-capacity } ;\r
\r
<PRIVATE\r
\r
: base-path ( string -- pair )
dup responder-nesting get
- [ second class superclasses [ word-name = ] with contains? ] with find nip
+ [ second class superclasses [ name>> = ] with contains? ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
: resolve-template-path ( pair -- path )
[
- first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi*
+ first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
] "" make ;
GENERIC: modify-query ( query responder -- query' )
IN: furnace.utilities
: word>string ( word -- string )
- [ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
+ [ vocabulary>> ] [ name>> ] bi ":" swap 3append ;
: words>strings ( seq -- seq' )
[ word>string ] map ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel namespaces parser prettyprint sequences
-words assocs definitions generic quotations effects slots
-continuations classes.tuple debugger combinators vocabs
+USING: accessors arrays io kernel namespaces parser prettyprint
+sequences words assocs definitions generic quotations effects
+slots continuations classes.tuple debugger combinators vocabs
help.stylesheet help.topics help.crossref help.markup sorting
classes vocabs.loader ;
IN: help
: all-errors ( -- seq )
all-words [ error? ] filter sort-articles ;
-M: word article-name word-name ;
+M: word article-name name>> ;
M: word article-title
dup [ parsing-word? ] [ symbol? ] bi or [
- word-name
+ name>>
] [
- [ word-name ]
+ [ name>> ]
[ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
append
] if ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences parser kernel help help.markup help.topics
-words strings classes tools.vocabs namespaces io
+USING: accessors sequences parser kernel help help.markup
+help.topics words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
] unless ;
: effect-values ( word -- seq )
- stack-effect dup effect-in swap effect-out append [
- {
- { [ dup word? ] [ word-name ] }
- { [ dup integer? ] [ drop "object" ] }
- { [ dup string? ] [ ] }
- } cond
- ] map prune natural-sort ;
+ stack-effect
+ [ in>> ] [ out>> ] bi append
+ [ (stack-picture) ] map
+ prune natural-sort ;
: contains-funky-elements? ( element -- ? )
{
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic io kernel assocs hashtables
-namespaces parser prettyprint sequences strings io.styles
-vectors words math sorting splitting classes
-slots vocabs help.stylesheet help.topics vocabs.loader ;
+USING: accessors arrays definitions generic io kernel assocs
+hashtables namespaces parser prettyprint sequences strings
+io.styles vectors words math sorting splitting classes slots
+vocabs help.stylesheet help.topics vocabs.loader ;
IN: help.markup
! Simple markup language.
first dup vocab-name swap ($vocab-link) ;
: $vocabulary ( element -- )
- first word-vocabulary [
+ first vocabulary>> [
"Vocabulary" $heading nl dup ($vocab-link)
] when* ;
GENERIC: ($instance) ( element -- )
M: word ($instance)
- dup word-name a/an write bl ($link) ;
+ dup name>> a/an write bl ($link) ;
M: string ($instance)
dup a/an write bl $snippet ;
: CHLOE-SINGLETON:
scan-word
- [ word-name ] [ '[ , singleton-component-tag ] ] bi
+ [ name>> ] [ '[ , singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: CHLOE-TUPLE:
scan-word
- [ word-name ] [ '[ , tuple-component-tag ] ] bi
+ [ name>> ] [ '[ , tuple-component-tag ] ] bi
define-chloe-tag ;
parsing
] } 1&& ;
: (flatten) ( quot -- )
- [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
+ [ dup flattenable? [ def>> (flatten) ] [ , ] if ] each ;
: retain-stack-overflow? ( error -- ? )
{ "kernel-error" 14 f f } = ;
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
] with-secure-context ;
-[ ] [ [ class word-name write ] server-test ] unit-test
+[ ] [ [ class name>> write ] server-test ] unit-test
[ "secure" ] [ client-test ] unit-test
-USING: system words sequences vocabs.loader ;
+USING: accessors system words sequences vocabs.loader ;
{
"io.unix.backend"
"io.unix.pipes"
} [ require ] each
-"io.unix." os word-name append require
+"io.unix." os name>> append require
nip number>string
] [
num-alt.
- swap [ word-name ] map "." join
+ swap [ name>> ] map "." join
append
] if ;
PREDICATE: local-writer < word "local-writer?" word-prop ;
: <local-writer> ( reader -- word )
- dup word-name "!" append f <word>
+ dup name>> "!" append f <word>
[ t "local-writer?" set-word-prop ] keep
[ "local-writer" set-word-prop ] 2keep
[ swap "local-reader" set-word-prop ] keep ;
: make-local ( name -- word )
"!" ?tail [
<local-reader>
- dup <local-writer> dup word-name set
+ dup <local-writer> dup name>> set
] [ <local> ] if
- dup dup word-name set ;
+ dup dup name>> set ;
: make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ;
: make-local-word ( name -- word )
- <local-word> dup dup word-name set ;
+ <local-word> dup dup name>> set ;
: push-locals ( assoc -- )
use get push ;
: log-message ( msg word level -- )\r
check-log-message\r
log-service get dup [\r
- [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip\r
+ [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip\r
4array "log-message" send-to-log-server\r
] [\r
4drop\r
HELP: parse-log
{ $values { "lines" "a sequence of strings" } { "entries" "a sequence of log entries" } }
-{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where"
+{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level name>> message }" } ", where"
{ $list
{ { $snippet "timestamp" } " is a " { $link timestamp } }
{ { $snippet "level" } " is a log level; see " { $link "logging.levels" } }
\r
: 'log-level' ( -- parser )\r
log-levels [\r
- [ word-name token ] keep [ nip ] curry <@\r
+ [ name>> token ] keep [ nip ] curry <@\r
] map <or-parser> ;\r
\r
: 'word-name' ( -- parser )\r
\r
: multiline-header 20 CHAR: - <string> ; foldable\r
\r
-: (write-message) ( msg word-name level multi? -- )\r
+: (write-message) ( msg name>> level multi? -- )\r
[\r
"[" write multiline-header write "] " write\r
] [\r
] if\r
write bl write ": " write print ;\r
\r
-: write-message ( msg word-name level -- )\r
+: write-message ( msg name>> level -- )\r
rot harvest {\r
{ [ dup empty? ] [ 3drop ] }\r
{ [ dup length 1 = ] [ first -rot f (write-message) ] }\r
} cond ;\r
\r
: (log-message) ( msg -- )\r
- #! msg: { msg word-name level service }\r
+ #! msg: { msg name>> level service }\r
first4 log-stream [ write-message flush ] with-output-stream* ;\r
\r
: try-dispose ( stream -- )\r
-! Copyright (C) 2006 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: math.complex.private
-USING: kernel kernel.private math math.private
+USING: accessors kernel kernel.private math math.private
math.libm math.functions prettyprint.backend arrays
math.functions.private sequences parser ;
+IN: math.complex.private
M: real real-part ;
M: real imaginary-part drop 0 ;
+M: complex real-part real>> ;
+M: complex imaginary-part imaginary>> ;
+
M: complex absq >rect [ sq ] bi@ + ;
: 2>rect ( x y -- xr yr xi yi )
HELP: rational
{ $class-description "The class of rational numbers, a disjoint union of integers and ratios." } ;
-HELP: numerator ( a/b -- a )
+HELP: numerator
{ $values { "a/b" rational } { "a" integer } }
{ $description "Outputs the numerator of a rational number. Acts as the identity on integers." } ;
-HELP: denominator ( a/b -- b )
+HELP: denominator
{ $values { "a/b" rational } { "b" "a positive integer" } }
{ $description "Outputs the denominator of a rational number. Always outputs 1 with integers." } ;
-! Copyright (C) 2004, 2006 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel kernel.private math math.functions math.private ;
IN: math.ratios
-USING: kernel kernel.private math math.functions math.private ;
: >fraction ( a/b -- a b )
dup numerator swap denominator ; inline
M: ratio >bignum >fraction /i >bignum ;
M: ratio >float >fraction /f ;
+M: ratio numerator numerator>> ;
+M: ratio denominator denominator>> ;
+
M: ratio < scale < ;
M: ratio <= scale <= ;
M: ratio > scale > ;
"forgotten" word-prop not ;
: method-word-name ( specializer generic -- string )
- [ word-name % "-" % unparse % ] "" make ;
+ [ name>> % "-" % unparse % ] "" make ;
: method-word-props ( specializer generic -- assoc )
[
{ SQL-DOUBLE [ *double ] }
{ SQL-TINYINT [ *char ] }
{ SQL-BIGINT [ *longlong ] }
- [ nip [ "Unknown SQL Type: " % word-name % ] "" make ]
+ [ nip [ "Unknown SQL Type: " % name>> % ] "" make ]
} case ;
TUPLE: field value column ;
r> drop r> [
"SQLGetData Failed for Column: " %
dup column-name %
- " of type: " % dup column-type word-name %
+ " of type: " % dup column-type name>> %
] "" make swap <field>
] if ;
[
dup param>> literalize ,
dup #label-loop? "#loop: " "#label: " ?
- over param>> word-name append comment,
+ over param>> name>> append comment,
] 2keep
node-child swap dataflow>quot , \ call , ;
M: object node>quot
[
- dup class word-name %
+ dup class name>> %
" " %
dup param>> unparse %
" " %
dataflow optimize dataflow>report ;
: word-optimize-report ( word -- report )
- word-def quot-optimize-report ;
+ def>> quot-optimize-report ;
: report. ( report -- )
[
] tabular-output ;\r
\r
: optimizer-report ( -- )\r
- all-words [ compiled? ] filter\r
+ all-words [ compiled>> ] filter\r
[\r
dup [\r
word-dataflow nip 1 count-optimization-passes\r
M: string present ;
-M: word present word-name ;
+M: word present name>> ;
M: effect present effect>string ;
GENERIC: word-noise-factor ( word -- factor )\r
\r
M: word word-noise-factor\r
- word-def quot-noise-factor ;\r
+ def>> quot-noise-factor ;\r
\r
M: lambda-word word-noise-factor\r
"lambda" word-prop quot-noise-factor ;\r
] tabular-output ; inline\r
\r
: optimizer-measurements ( -- alist )\r
- all-words [ compiled? ] filter\r
+ all-words [ compiled>> ] filter\r
[\r
dup [\r
word-dataflow nip 1 count-optimization-passes\r
<PRIVATE
-: default-word-name ( relate-word-name word-type -- word-name )
+: default-word-name ( relate-word-name word-type -- name>> )
{
{ "relate" [ ] }
{ "id-word" [ "-relation" append ] }
{ "objects" [ "-objects" append ] }
} case ;
-: choose-word-name ( relation-definition given-word-name word-type -- word-name )
+: choose-word-name ( relation-definition given-word-name word-type -- name>> )
over string? [
drop nip
] [
nip [ relate>> ] dip default-word-name
] if ;
-: (define-relation-word) ( id-word word-name definition -- id-word )
+: (define-relation-word) ( id-word name>> definition -- id-word )
>r create-in over [ execute ] curry r> compose define ;
: define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word )
2drop ;
: define-id-word ( relation-definition id-word -- )
- [ relate>> ] dip tuck word-vocabulary
+ [ relate>> ] dip tuck vocabulary>>
[ ensure-context ensure-relation ] 2curry define ;
: create-id-word ( relation-definition -- id-word )
[
CHAR: G write1
[ add-object ]
- [ word-def (serialize) ]
- [ word-props (serialize) ]
+ [ def>> (serialize) ]
+ [ props>> (serialize) ]
tri
] serialize-shared ;
: serialize-word ( word -- )
CHAR: w write1
- [ word-name (serialize) ]
- [ word-vocabulary (serialize) ]
+ [ name>> (serialize) ]
+ [ vocabulary>> (serialize) ]
bi ;
M: word (serialize) ( obj -- )
{
{ [ dup t eq? ] [ serialize-true ] }
- { [ dup word-vocabulary not ] [ serialize-gensym ] }
+ { [ dup vocabulary>> not ] [ serialize-gensym ] }
[ serialize-word ]
} cond ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words parser io inspector quotations sequences
-prettyprint continuations effects definitions compiler.units
-namespaces assocs tools.walker generic ;
+USING: accessors kernel words parser io inspector quotations
+sequences prettyprint continuations effects definitions
+compiler.units namespaces assocs tools.walker generic ;
IN: tools.annotations
GENERIC: reset ( word -- )
"Cannot annotate a word twice" throw
] when
[
- over dup word-def "unannotated-def" set-word-prop
- >r dup word-def r> call define
+ over dup def>> "unannotated-def" set-word-prop
+ >r dup def>> r> call define
] with-compilation-unit ; inline
: word-inputs ( word -- seq )
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions assocs io kernel
+USING: accessors arrays definitions assocs io kernel
math namespaces prettyprint sequences strings io.styles words
generic tools.completion quotations parser inspector
sorting hashtables vocabs parser source-files ;
smart-usage sorted-definitions. ;
: words-matching ( str -- seq )
- all-words [ dup word-name ] { } map>assoc completions ;
+ all-words [ dup name>> ] { } map>assoc completions ;
: apropos ( str -- )
words-matching synopsis-alist reverse definitions. ;
: strip-word-names ( words -- )
"Stripping word names" show
- [ f over set-word-name f swap set-word-vocabulary ] each ;
+ [ f over set-word-name f swap set-vocabulary>> ] each ;
: strip-word-defs ( words -- )
"Stripping symbolic word definitions" show
"Stripping word properties" show
[
[
- word-props swap
- '[ , nip member? not ] assoc-filter
+ props>> swap
+ '[ drop , member? not ] assoc-filter
f assoc-like
] keep set-word-props
] with each ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: words sequences math prettyprint kernel arrays io
+USING: accessors words sequences math prettyprint kernel arrays io
io.styles namespaces assocs kernel.private strings combinators
sorting math.parser vocabs definitions tools.profiler.private
continuations generic ;
[ t profiling call ] [ f profiling ] [ ] cleanup ;
: counters ( words -- assoc )
- [ dup profile-counter ] { } map>assoc ;
+ [ dup counter>> ] { } map>assoc ;
GENERIC: (profile.) ( obj -- )
vocabs [
dup words
[ "predicating" word-prop not ] filter
- [ profile-counter ] map sum
+ [ counter>> ] map sum
] { } map>assoc counters. ;
: method-profile. ( -- )
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators vocabs vocabs.loader tools.vocabs io
-io.files io.styles help.markup help.stylesheet sequences assocs
-help.topics namespaces prettyprint words sorting definitions
-arrays inspector sets ;
+USING: accessors kernel combinators vocabs vocabs.loader
+tools.vocabs io io.files io.styles help.markup help.stylesheet
+sequences assocs help.topics namespaces prettyprint words
+sorting definitions arrays inspector sets ;
IN: tools.vocabs.browser
: vocab-status-string ( vocab -- string )
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words r> map
- [ [ word? ] filter [ word-vocabulary ] map ] gather natural-sort
+ [ [ word? ] filter [ vocabulary>> ] map ] gather natural-sort
remove sift [ vocab ] map ; inline
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
{ [ dup uses \ suspend swap member? ] [ execute break ] }
{ [ dup primitive? ] [ execute break ] }
- [ word-def (step-into-quot) ]
+ [ def>> (step-into-quot) ]
} cond ;
\ (step-into-execute) t "step-into?" set-word-prop
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions kernel sequences strings math assocs
-words generic namespaces assocs quotations splitting
+USING: accessors arrays definitions kernel sequences strings
+math assocs words generic namespaces assocs quotations splitting
ui.gestures unicode.case unicode.categories ;
IN: ui.commands
{ { CHAR: - CHAR: \s } } substitute >title ;
M: word command-name ( word -- str )
- word-name
+ name>>
"com-" ?head drop
dup first Letter? [ rest ] unless
(command-name) ;
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
: define-command ( word hash -- )
- [ word-props ] [ default-flags swap assoc-union ] bi* update ;
+ [ props>> ] [ default-flags swap assoc-union ] bi* update ;
: command-quot ( target command -- quot )
dup 1quotation swap +nullary+ word-prop
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math models namespaces
+USING: accessors arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
math.vectors classes.tuple classes ui.gadgets boxes
calendar alarms symbols combinators sets columns ;
GENERIC: gesture>string ( gesture -- string/f )
: modifiers>string ( modifiers -- string )
- [ word-name ] map concat >string ;
+ [ name>> ] map concat >string ;
M: key-down gesture>string
dup key-down-mods modifiers>string
GENERIC: word-completion-string ( word -- string )
M: word word-completion-string
- word-name ;
+ name>> ;
M: method-body word-completion-string
"method-generic" word-prop word-completion-string ;
"engine-generic" word-prop word-completion-string ;
: use-if-necessary ( word seq -- )
- over word-vocabulary [
+ over vocabulary>> [
2dup assoc-stack pick = [ 2drop ] [
- >r word-vocabulary vocab-words r> push
+ >r vocabulary>> vocab-words r> push
] if
] [ 2drop ] if ;
M: quotation com-stack-effect infer. ;
-M: word com-stack-effect word-def com-stack-effect ;
+M: word com-stack-effect def>> com-stack-effect ;
[ word? ] \ com-stack-effect H{
{ +listener+ t }
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs ui.tools.interactor ui.tools.listener
+USING: accessors assocs ui.tools.interactor ui.tools.listener
ui.tools.workspace help help.topics io.files io.styles kernel
models namespaces prettyprint quotations sequences sorting
source-files definitions strings tools.completion tools.crossref
>r definition-candidates r> [ synopsis ] <live-search> ;
: word-candidates ( words -- candidates )
- [ dup word-name >lower ] { } map>assoc ;
+ [ dup name>> >lower ] { } map>assoc ;
: <word-search> ( string words limited? -- gadget )
>r word-candidates r> [ synopsis ] <live-search> ;
: show-word-usage ( workspace word -- )
"" over smart-usage f <definition-search>
- "Words and methods using " rot word-name append
+ "Words and methods using " rot name>> append
show-titled-popup ;
: help-candidates ( seq -- candidates )
"uint" { "void*" "uint" "long" "long" } "stdcall" [
[
pick
- trace-messages? get-global [ dup windows-message-name word-name print flush ] when
+ trace-messages? get-global [ dup windows-message-name name>> print flush ] when
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
] ui-try
] alien-callback ;
-USING: values kernel sequences assocs io.files
+USING: accessors values kernel sequences assocs io.files
io.encodings ascii math.ranges io splitting math.parser
namespaces byte-arrays locals math sets io.encodings.ascii
words compiler.units arrays interval-maps unicode.data ;
: range, ( value key -- )
swap interned get
- [ word-name = ] with find nip 2array , ;
+ [ name>> = ] with find nip 2array , ;
: expand-ranges ( assoc -- interval-map )
[
USING: alien.syntax system sequences vocabs.loader words ;
IN: unix.kqueue
-<< "unix.kqueue." os word-name append require >>
+<< "unix.kqueue." os name>> append require >>
FUNCTION: int kqueue ( ) ;
M: no-such-state summary drop "No such state" ;
MEMO: string>state ( string -- state )
- dup states [ word-name = ] with find nip
+ dup states [ name>> = ] with find nip
[ ] [ no-such-state ] ?if ;
TUPLE: city
-USING: kernel parser sequences words effects ;
+USING: accessors kernel parser sequences words effects ;
IN: values
: VALUE:
(( -- value )) define-declared ; parsing
: set-value ( value word -- )
- word-def first set-first ;
+ def>> first set-first ;
: get-value ( word -- value )
- word-def first first ;
+ def>> first first ;
: change-value ( word quot -- )
over >r >r get-value r> call r> set-value ; inline
IN: vars
: define-var-getter ( word -- )
- [ word-name ">" append create-in ] [ [ get ] curry ] bi
+ [ name>> ">" append create-in ] [ [ get ] curry ] bi
(( -- value )) define-declared ;
: define-var-setter ( word -- )
- [ word-name ">" prepend create-in ] [ [ set ] curry ] bi
+ [ name>> ">" prepend create-in ] [ [ set ] curry ] bi
(( value -- )) define-declared ;
: define-var ( str -- )
SYMBOL: windows-messages
"windows.messages" words
-[ word-name "windows-message" head? not ] filter
+[ name>> "windows-message" head? not ] filter
[ dup execute swap ] { } map>assoc
windows-messages set-global
"Tag <" write
dup process-missing-tag print-name
"> not implemented on process process " write
- process-missing-process word-name print ;
+ process-missing-process name>> print ;
: run-process ( tag word -- )
2dup "xtable" word-prop
: htmlize-tokens ( tokens -- )
[
[ str>> ] [ id>> ] bi [
- <span word-name =class span> escape-string write </span>
+ <span name>> =class span> escape-string write </span>
] [
escape-string write
] if*
{ "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [
create-in dup define-symbol
- dup word-name swap
+ dup name>> swap
] H{ } map>assoc tokens set-global
>>
projects / factor.git / commitdiff