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 ;
-UNION: c-ptr
-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 ;
-USING: arrays kernel sequences sequences.private growable
+USING: accessors arrays kernel sequences sequences.private growable
tools.test vectors layouts system math vectors.private ;
IN: arrays.tests
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
[ f ] [ { "a" "b" "c" } dup >array eq? ] unit-test
[ t ] [ { "a" "b" "c" } dup { } like eq? ] unit-test
-[ t ] [ { "a" "b" "c" } dup dup length array>vector underlying eq? ] unit-test
+[ t ] [ { "a" "b" "c" } dup dup length array>vector underlying>> eq? ] unit-test
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } V{ } like ] unit-test
[ { "a" "b" "c" } ] [ { "a" } { "b" "c" } append ] unit-test
[ { "a" "b" "c" "d" "e" } ]
! 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*
+} compile-uncompiled
+"." write flush
+
+{
bitand bitor bitxor bitnot
} compile-uncompiled
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
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables
-hashtables.private io kernel math namespaces parser sequences
-strings vectors words quotations assocs layouts classes
-classes.builtin classes.tuple classes.tuple.private
+hashtables.private io kernel math math.order namespaces parser
+sequences 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
-compiler.units bootstrap.image.private io.files accessors
-combinators ;
+slots classes.union classes.intersection classes.predicate
+compiler.units bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
"classes.private"
"classes.tuple"
"classes.tuple.private"
+ "classes.predicate"
"compiler.units"
"continuations.private"
"float-arrays"
} [ create-vocab drop ] each
! Builtin classes
-: lo-tag-eq-quot ( n -- quot )
- [ \ tag , , \ eq? , ] [ ] make ;
-
-: hi-tag-eq-quot ( n -- quot )
- [
- [ dup tag ] % \ hi-tag tag-number , \ eq? ,
- [ [ hi-tag ] % , \ eq? , ] [ ] make ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
-
-: builtin-predicate-quot ( class -- quot )
- "type" word-prop
- dup tag-mask get <
- [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
-
: define-builtin-predicate ( class -- )
- dup builtin-predicate-quot define-predicate ;
+ dup class>type [ builtin-instance? ] curry define-predicate ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
[ 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 pair? [ 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
"byte-array" "byte-arrays" create register-builtin
"tuple-layout" "classes.tuple.private" create register-builtin
+! For predicate classes
+"predicate-instance?" "classes.predicate" create drop
+
+! We need this before defining c-ptr below
+"f" "syntax" lookup { } define-builtin
+
+"f" "syntax" create [ not ] "predicate" set-word-prop
+"f?" "syntax" vocab-words delete-at
+
+! Some unions
+"integer" "math" create
+"fixnum" "math" lookup
+"bignum" "math" lookup
+2array
+define-union-class
+
+"rational" "math" create
+"integer" "math" lookup
+"ratio" "math" lookup
+2array
+define-union-class
+
+"real" "math" create
+"rational" "math" lookup
+"float" "math" lookup
+2array
+define-union-class
+
+"c-ptr" "alien" create [
+ "alien" "alien" lookup ,
+ "f" "syntax" lookup ,
+ "byte-array" "byte-arrays" lookup ,
+ "bit-array" "bit-arrays" lookup ,
+ "float-array" "float-arrays" lookup ,
+] { } make define-union-class
+
+! A predicate class used for declarations
+"array-capacity" "sequences.private" create
+"fixnum" "math" lookup
+0 bootstrap-max-array-capacity [ between? ] 2curry
+define-predicate-class
+
! Catch-all class for providing a default method.
"object" "kernel" create
[ f f { } intersection-class define-class ]
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
"ratio" "math" create {
- {
- { "integer" "math" }
- "numerator"
- { "numerator" "math" }
- f
- }
- {
- { "integer" "math" }
- "denominator"
- { "denominator" "math" }
- f
- }
+ { "numerator" { "integer" "math" } read-only }
+ { "denominator" { "integer" "math" } read-only }
} define-builtin
"float" "math" create { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
"complex" "math" create {
- {
- { "real" "math" }
- "real-part"
- { "real-part" "math" }
- f
- }
- {
- { "real" "math" }
- "imaginary-part"
- { "imaginary-part" "math" }
- f
- }
+ { "real" { "real" "math" } read-only }
+ { "imaginary" { "real" "math" } read-only }
} define-builtin
-"f" "syntax" lookup { } define-builtin
-
"array" "arrays" create { } define-builtin
"wrapper" "kernel" create {
- {
- { "object" "kernel" }
- "wrapped"
- { "wrapped" "kernel" }
- f
- }
+ { "wrapped" read-only }
} define-builtin
"string" "strings" create {
- {
- { "array-capacity" "sequences.private" }
- "length"
- { "length" "sequences" }
- f
- } {
- { "object" "kernel" }
- "aux"
- { "string-aux" "strings.private" }
- { "set-string-aux" "strings.private" }
- }
+ { "length" { "array-capacity" "sequences.private" } read-only }
+ "aux"
} define-builtin
"quotation" "quotations" create {
- {
- { "object" "kernel" }
- "array"
- { "quotation-array" "quotations.private" }
- f
- }
- {
- { "object" "kernel" }
- "compiled?"
- { "quotation-compiled?" "quotations" }
- f
- }
+ { "array" { "array" "arrays" } read-only }
+ { "compiled" read-only }
} define-builtin
"dll" "alien" create {
- {
- { "byte-array" "byte-arrays" }
- "path"
- { "(dll-path)" "alien" }
- f
- }
+ { "path" { "byte-array" "byte-arrays" } read-only }
}
define-builtin
"alien" "alien" create {
- {
- { "c-ptr" "alien" }
- "alien"
- { "underlying-alien" "alien" }
- f
- } {
- { "object" "kernel" }
- "expired?"
- { "expired?" "alien" }
- f
- }
+ { "underlying" { "c-ptr" "alien" } read-only }
+ { "expired?" read-only }
}
define-builtin
"word" "words" create {
- f
- {
- { "object" "kernel" }
- "name"
- { "word-name" "words" }
- { "set-word-name" "words" }
- }
- {
- { "object" "kernel" }
- "vocabulary"
- { "word-vocabulary" "words" }
- { "set-word-vocabulary" "words" }
- }
- {
- { "quotation" "quotations" }
- "def"
- { "word-def" "words" }
- { "set-word-def" "words.private" }
- }
- {
- { "object" "kernel" }
- "props"
- { "word-props" "words" }
- { "set-word-props" "words" }
- }
- {
- { "object" "kernel" }
- "compiled?"
- { "compiled?" "words" }
- f
- }
- {
- { "fixnum" "math" }
- "counter"
- { "profile-counter" "tools.profiler.private" }
- { "set-profile-counter" "tools.profiler.private" }
- }
+ { "hashcode" { "fixnum" "math" } }
+ "name"
+ "vocabulary"
+ { "def" { "quotation" "quotations" } initial: [ ] }
+ "props"
+ { "compiled" read-only }
+ { "counter" { "fixnum" "math" } }
} define-builtin
"byte-array" "byte-arrays" create { } define-builtin
"callstack" "kernel" create { } define-builtin
"tuple-layout" "classes.tuple.private" create {
- {
- { "fixnum" "math" }
- "hashcode"
- { "layout-hashcode" "classes.tuple.private" }
- f
- }
- {
- { "word" "words" }
- "class"
- { "layout-class" "classes.tuple.private" }
- f
- }
- {
- { "fixnum" "math" }
- "size"
- { "layout-size" "classes.tuple.private" }
- f
- }
- {
- { "array" "arrays" }
- "superclasses"
- { "layout-superclasses" "classes.tuple.private" }
- f
- }
- {
- { "fixnum" "math" }
- "echelon"
- { "layout-echelon" "classes.tuple.private" }
- f
- }
+ { "hashcode" { "fixnum" "math" } read-only }
+ { "class" { "word" "words" } initial: t read-only }
+ { "size" { "fixnum" "math" } read-only }
+ { "superclasses" { "array" "arrays" } initial: { } read-only }
+ { "echelon" { "fixnum" "math" } read-only }
} define-builtin
"tuple" "kernel" create {
[ { "delegate" } "slot-names" set-word-prop ]
[ define-tuple-layout ]
[
- {
- {
- { "object" "kernel" }
- "delegate"
- { "delegate" "kernel" }
- { "set-delegate" "kernel" }
- }
- }
+ { "delegate" }
[ drop ] [ generate-tuple-slots ] 2bi
[ "slots" set-word-prop ]
- [ define-slots ]
+ [ define-accessors ]
2bi
]
} cleave
-"f" "syntax" create [ not ] "predicate" set-word-prop
-"f?" "syntax" vocab-words delete-at
-
! Create special tombstone values
"tombstone" "hashtables.private" create
tuple
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" }
- "quot"
- { "curry-quot" "kernel" }
- f
- }
-} define-tuple-class
+ { "obj" read-only }
+ { "quot" read-only }
+} prepare-slots define-tuple-class
"curry" "kernel" lookup
[ f "inline" set-word-prop ]
"compose" "kernel" create
tuple
{
- {
- { "object" "kernel" }
- "first"
- { "compose-first" "kernel" }
- f
- } {
- { "object" "kernel" }
- "second"
- { "compose-second" "kernel" }
- f
- }
-} define-tuple-class
+ { "first" read-only }
+ { "second" read-only }
+} 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
--- /dev/null
+IN: classes.builtin.tests
+USING: tools.test words sequences kernel memory accessors ;
+
+[ f ] [
+ [ word? ] instances
+ [
+ [ name>> "f?" = ]
+ [ vocabulary>> "syntax" = ] bi and
+ ] contains?
+] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes words kernel kernel.private namespaces
-sequences ;
+sequences math math.private ;
IN: classes.builtin
SYMBOL: builtins
: type>class ( n -- class ) builtins get-global nth ;
+: class>type ( class -- n ) "type" word-prop ; foldable
+
: bootstrap-type>class ( n -- class ) builtins get nth ;
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;
M: builtin-class rank-class drop 0 ;
+
+: builtin-instance? ( object n -- ? )
+ #! 7 == tag-mask get
+ #! 3 == hi-tag tag-number
+ dup 7 fixnum<= [ swap tag eq? ] [
+ swap dup tag 3 eq?
+ [ hi-tag eq? ] [ 2drop f ] if
+ ] if ; inline
+
+M: builtin-class instance?
+ class>type builtin-instance? ;
! 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 ]
] each ;
M: class forget* ( class -- )
- [ forget-class ] [ call-next-method ] bi ;
+ [ call-next-method ] [ forget-class ] bi ;
GENERIC: class ( object -- class )
-: instance? ( obj class -- ? )
- "predicate" word-prop call ;
+GENERIC: instance? ( object class -- ? )
2bi ;
M: intersection-class rank-class drop 2 ;
+
+M: intersection-class instance?
+ "participants" word-prop [ instance? ] with all? ;
[ class>> ] [ mixin>> ] bi 2array hashcode* ;
: <mixin-instance> ( class mixin -- definition )
- { set-mixin-instance-class set-mixin-instance-mixin }
- mixin-instance construct ;
+ mixin-instance new
+ swap >>mixin
+ swap >>class ;
M: mixin-instance where mixin-instance-loc ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes kernel namespaces words ;
+USING: classes kernel namespaces words sequences quotations
+arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
+DEFER: predicate-instance? ( object class -- ? )
+
+: update-predicate-instance ( -- )
+ \ predicate-instance? bootstrap-word
+ classes [ predicate-class? ] filter [
+ [ literalize ]
+ [
+ [ superclass 1array [ declare ] curry ]
+ [ "predicate-definition" word-prop ]
+ bi compose
+ ]
+ bi
+ ] { } map>assoc [ case ] curry
+ define ;
+
: predicate-quot ( class -- quot )
[
\ dup ,
[ dup predicate-quot define-predicate ]
[ update-classes ]
bi
- ] 3tri ;
+ ]
+ 3tri
+ update-predicate-instance ;
M: predicate-class reset-class
[ call-next-method ]
bi ;
M: predicate-class rank-class drop 1 ;
+
+M: predicate-class instance?
+ 2dup superclass instance?
+ [ predicate-instance? ] [ 2drop f ] if ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.predicate kernel sequences words ;
+USING: classes classes.predicate kernel sequences words ;
IN: classes.singleton
PREDICATE: singleton-class < predicate-class
: define-singleton-class ( word -- )
\ word over [ eq? ] curry define-predicate-class ;
+
+M: singleton-class instance? eq? ;
--- /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 ] [ "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
+
+[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot alien } ;" eval ]
+[ error>> no-initial-value? ]
+must-fail-with
+
+[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
+[ error>> bad-initial-value? ]
+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-long-slot-name ( -- )
+ [ scan , \ } parse-until % ] { } make ;
+
+: parse-slot-name ( string/f -- ? )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
#! 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-long-slot-name ] 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:"
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector
-columns math.order classes.private slots.private ;
+columns math.order classes.private slots slots.private ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
[ 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>
! Typo
SYMBOL: not-a-tuple-class
-[
- "IN: classes.tuple.tests C: <not-a-tuple-class> not-a-tuple-class"
- eval
-] must-fail
-
-[ t ] [
- "not-a-tuple-class" "classes.tuple.tests" lookup symbol?
-] unit-test
-
! Missing check
[ not-a-tuple-class boa ] must-fail
[ not-a-tuple-class new ] must-fail
[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
-[
- "IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ error>> not-a-tuple-class? ] must-fail-with
-
! Inheritance
TUPLE: computer cpu ram ;
C: <computer> computer
[ laptop ] [
"laptop" get 1 slot
- dup layout-echelon swap
- layout-superclasses nth
+ dup echelon>> swap
+ superclasses>> nth
] unit-test
[ "TUPLE: laptop < computer battery ;" ] [
] with-compilation-unit
] unit-test
-[ "USE: words T{ word }" eval ] [ error>> not-a-tuple-class? ] must-fail-with
+[ "USE: words T{ word }" eval ]
+[ error>> T{ no-method f word slots>tuple } = ]
+must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
! Insufficient type checking
[ \ vocab tuple>array drop ] must-fail
+
+! Check type declarations
+TUPLE: declared-types { n fixnum } { m string } ;
+
+[ T{ declared-types f 0 "hi" } ]
+[ { declared-types f 0 "hi" } >tuple ]
+unit-test
+
+[ { declared-types f "hi" 0 } >tuple ]
+[ T{ bad-slot-value f "hi" fixnum } = ]
+must-fail-with
+
+[ T{ declared-types f 0 "hi" } ]
+[ 0.0 "hi" declared-types boa ] unit-test
+
+: foo ( a b -- c ) declared-types boa ;
+
+\ foo must-infer
+
+[ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
+
+[ "hi" 0.0 declared-types boa ]
+[ T{ no-method f "hi" >fixnum } = ]
+must-fail-with
+
+[ 0 { } declared-types boa ]
+[ T{ bad-slot-value f { } string } = ]
+must-fail-with
+
+[ "hi" 0.0 foo ]
+[ T{ no-method f "hi" >fixnum } = ]
+must-fail-with
+
+[ 0 { } foo ]
+[ T{ bad-slot-value f { } string } = ]
+must-fail-with
+
+[ T{ declared-types f 0 "" } ] [ declared-types new ] unit-test
+
+: blah ( -- vec ) vector new ;
+
+\ blah must-infer
+
+[ V{ } ] [ blah ] unit-test
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
-ERROR: not-a-tuple-class class ;
-
-: check-tuple-class ( class -- class )
- dup tuple-class? [ not-a-tuple-class ] unless ; inline
-
<PRIVATE
+: (tuple) ( layout -- tuple )
+ #! In non-optimized code, this word simply calls the
+ #! <tuple> primitive. In optimized code, an intrinsic
+ #! is generated which allocates a tuple but does not set
+ #! any of its slots. This means that any code that uses
+ #! (tuple) must fill in the slots before the next
+ #! call to GC.
+ #!
+ #! This word is only used in the expansion of <tuple-boa>,
+ #! where this invariant is guaranteed to hold.
+ <tuple> ;
+
: tuple-layout ( class -- layout )
- check-tuple-class "layout" word-prop ;
+ "layout" word-prop ;
+
+: layout-of ( tuple -- layout )
+ 1 slot { tuple-layout } declare ; inline
: tuple-size ( tuple -- size )
- 1 slot layout-size ; inline
+ layout-of size>> ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
- check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ;
+ check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
: 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 ;
-: slots>tuple ( tuple class -- array )
+: all-slots ( class -- slots )
+ superclasses [ "slots" word-prop ] map concat ;
+
+: check-slots ( seq class -- seq class )
+ [ ] [
+ 2dup all-slots [
+ class>> 2dup instance?
+ [ 2drop ] [ bad-slot-value ] if
+ ] 2each
+ ] if-bootstrapping ; inline
+
+GENERIC: slots>tuple ( seq class -- tuple )
+
+M: tuple-class slots>tuple
+ check-slots
tuple-layout <tuple> [
- [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
+ [ tuple-size ]
+ [ [ set-array-nth ] curry ]
+ bi 2each
] keep ;
-: >tuple ( tuple -- seq )
+: >tuple ( seq -- tuple )
unclip slots>tuple ;
: slot-names ( class -- seq )
- "slot-names" word-prop
- [ dup array? [ second ] when ] map ;
+ "slot-names" word-prop ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
- 2dup [ 1 slot ] bi@ eq? [
+ 2dup [ layout-of ] bi@ eq? [
[ drop tuple-size ]
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
2bi all-integers?
] [
2drop f
- ] if ;
+ ] if ; inline
-! Predicate generation. We optimize at the expense of simplicity
-
-: (tuple-predicate-quot) ( class -- quot )
- #! 4 slot == layout-superclasses
- #! 5 slot == layout-echelon
- [
- [ 1 slot dup 5 slot ] %
- dup tuple-layout layout-echelon ,
- [ fixnum>= ] %
- [
- dup tuple-layout layout-echelon ,
- [ swap 4 slot array-nth ] %
- literalize ,
- [ eq? ] %
- ] [ ] make ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
-
-: tuple-predicate-quot ( class -- quot )
- [
- [ dup tuple? ] %
- (tuple-predicate-quot) ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
+: tuple-instance? ( object class echelon -- ? )
+ #! 4 slot == superclasses>>
+ rot dup tuple? [
+ layout-of 4 slot
+ 2dup array-capacity fixnum<
+ [ array-nth eq? ] [ 3drop f ] if
+ ] [ 3drop f ] if ; inline
: define-tuple-predicate ( class -- )
- dup tuple-predicate-quot define-predicate ;
+ dup dup tuple-layout echelon>>
+ [ tuple-instance? ] 2curry define-predicate ;
: superclass-size ( class -- n )
superclasses but-last-slice
[ slot-names length ] map sum ;
+: (instance-check-quot) ( class -- quot )
+ [
+ \ dup ,
+ [ "predicate" word-prop % ]
+ [ [ bad-slot-value ] curry , ] bi
+ \ unless ,
+ ] [ ] make ;
+
+: instance-check-quot ( class -- quot )
+ {
+ { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
+ { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
+ [ (instance-check-quot) ]
+ } cond ;
+
+: boa-check-quot ( class -- quot )
+ all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ;
+
+: define-boa-check ( class -- )
+ dup boa-check-quot "boa-check" set-word-prop ;
+
+: tuple-prototype ( class -- prototype )
+ [ all-slots [ initial>> ] map ] keep slots>tuple ;
+
+: define-tuple-prototype ( class -- )
+ dup tuple-prototype "prototype" set-word-prop ;
+
: 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
outdated-tuples get [ all-slot-names ] cache drop ;
M: tuple-class update-class
- [ define-tuple-layout ]
- [ define-tuple-slots ]
- [ define-tuple-predicate ]
- tri ;
+ {
+ [ define-tuple-layout ]
+ [ define-tuple-slots ]
+ [ define-tuple-predicate ]
+ [ define-tuple-prototype ]
+ [ define-boa-check ]
+ } cleave ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f f tuple-class define-class ]
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 ]
- bi
+ [
+ {
+ "layout" "slots" "slot-names" "boa-check" "prototype"
+ } reset-props
+ ] bi
] bi ;
M: tuple-class rank-class drop 0 ;
+M: tuple-class instance?
+ dup tuple-layout echelon>> tuple-instance? ;
+
M: tuple clone
(clone) dup delegate clone over set-delegate ;
] 2curry each
] recursive-hashcode ;
+M: tuple-class new
+ "prototype" word-prop (clone) ;
+
+M: tuple-class boa
+ [ "boa-check" word-prop call ]
+ [ tuple-layout ]
+ bi <tuple-boa> ;
+
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
[ (define-union-class) ] [ drop update-classes ] 2bi ;
M: union-class rank-class drop 2 ;
+
+M: union-class instance?
+ "members" word-prop [ instance? ] with contains? ;
USING: alien strings kernel math tools.test io prettyprint
-namespaces combinators words classes sequences ;
+namespaces combinators words classes sequences accessors
+math.functions ;
IN: combinators.tests
! Compiled
[ "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' )
{
: do-not-call "do not call" throw ;
-: test-case-6
+: test-case-6 ( obj -- value )
{
{ \ do-not-call [ "do-not-call" ] }
{ 3 [ "three" ] }
} case ;
+\ test-case-6 must-infer
+
[ "three" ] [ 3 test-case-6 ] unit-test
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
] unit-test
! Interpreted
-[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
-
-[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
-[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
-[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
-[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
-[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
-[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
+[ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test
+
+[ t ] [ { 1 3 2 } contiguous-range? ] unit-test
+[ f ] [ { 1 2 2 4 } contiguous-range? ] unit-test
+[ f ] [ { + 3 2 } contiguous-range? ] unit-test
+[ f ] [ { 1 0 7 } contiguous-range? ] unit-test
+[ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test
+[ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
+
+: test-case-7 ( obj -- str )
+ {
+ { \ + [ "plus" ] }
+ { \ - [ "minus" ] }
+ { \ * [ "times" ] }
+ { \ / [ "divide" ] }
+ { \ ^ [ "power" ] }
+ { \ [ [ "obama" ] }
+ { \ ] [ "KFC" ] }
+ } case ;
+
+\ test-case-7 must-infer
+
+[ "plus" ] [ \ + test-case-7 ] 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
+! cleave
: cleave ( x seq -- )
[ call ] with each ;
: cleave>quot ( seq -- quot )
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
+! 2cleave
: 2cleave ( x seq -- )
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
+! 3cleave
: 3cleave ( x seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
+! spread
: spread>quot ( seq -- quot )
- [ length [ >r ] <repetition> concat ]
- [ [ [ r> ] prepend ] map concat ] bi
- append [ ] like ;
+ [ ] [
+ [ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
+ append
+ ] reduce ;
: spread ( objs... seq -- )
spread>quot call ;
+! cond
ERROR: no-cond ;
: cond ( assoc -- )
[ dup callable? [ call ] [ second call ] if ]
[ no-cond ] if* ;
+: alist>quot ( default assoc -- quot )
+ [ rot \ if 3array append [ ] like ] assoc-each ;
+
+: cond>quot ( assoc -- quot )
+ [ dup callable? [ [ t ] swap 2array ] when ] map
+ reverse [ no-cond ] swap alist>quot ;
+
+! case
ERROR: no-case ;
+
: case-find ( obj assoc -- obj' )
[
dup array? [
dupd first dup word? [
execute
] [
- dup wrapper? [ wrapped ] when
+ dup wrapper? [ wrapped>> ] when
] if =
] [ quotation? ] if
] find nip ;
{ [ dup not ] [ no-case ] }
} cond ;
-: with-datastack ( stack quot -- newstack )
- datastack >r
- >r >array set-datastack r> call
- datastack r> swap suffix set-datastack 2nip ; inline
-
-: recursive-hashcode ( n obj quot -- code )
- pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
-
-! These go here, not in sequences and hashtables, since those
-! two depend on combinators
-M: sequence hashcode*
- [ sequence-hashcode ] recursive-hashcode ;
-
-M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
-
-M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
-
-M: hashtable hashcode*
- [
- dup assoc-size 1 number=
- [ assoc-hashcode ] [ nip assoc-size ] if
- ] recursive-hashcode ;
-
-: alist>quot ( default assoc -- quot )
- [ rot \ if 3array append [ ] like ] assoc-each ;
-
-: cond>quot ( assoc -- quot )
- [ dup callable? [ [ t ] swap 2array ] when ] map
- reverse [ no-cond ] swap alist>quot ;
-
: linear-case-quot ( default assoc -- quot )
[
[ 1quotation \ dup prefix \ = suffix ]
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
- [ linear-case-quot ] with map ;
+ [ [ >r literalize r> ] assoc-map linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] prepend ;
-: contiguous-range? ( keys -- from to ? )
+: contiguous-range? ( keys -- ? )
dup [ fixnum? ] all? [
dup all-unique? [
- dup infimum over supremum
- [ - swap prune length + 1 = ] 2keep rot
- ] [
- drop f f f
- ] if
- ] [
- drop f f f
- ] if ;
+ [ prune length ]
+ [ [ supremum ] [ infimum ] bi - ]
+ bi - 1 =
+ ] [ drop f ] if
+ ] [ drop f ] if ;
: dispatch-case ( value from to default array -- )
>r >r 3dup between? [
2drop r> call r> drop
] if ; inline
-: dispatch-case-quot ( default assoc from to -- quot )
- -roll -roll sort-keys values [ >quotation ] map
+: dispatch-case-quot ( default assoc -- quot )
+ [ nip keys [ infimum ] [ supremum ] bi ] 2keep
+ sort-keys values [ >quotation ] map
[ dispatch-case ] 2curry 2curry ;
: case>quot ( default assoc -- quot )
- dup empty? [
- drop
- ] [
- dup length 4 <=
- over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
- [
- linear-case-quot
- ] [
- dup keys contiguous-range? [
- dispatch-case-quot
- ] [
- 2drop hash-case-quot
- ] if
- ] if
- ] if ;
+ dup keys {
+ { [ dup empty? ] [ 2drop ] }
+ { [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] }
+ { [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
+ { [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] }
+ { [ dup [ wrapper? ] all? ] [ drop [ >r wrapped>> r> ] assoc-map hash-case-quot ] }
+ [ drop linear-case-quot ]
+ } cond ;
+
+! with-datastack
+: with-datastack ( stack quot -- newstack )
+ datastack >r
+ >r >array set-datastack r> call
+ datastack r> swap suffix set-datastack 2nip ; inline
+
+! recursive-hashcode
+: recursive-hashcode ( n obj quot -- code )
+ pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
+
+! These go here, not in sequences and hashtables, since those
+! two cannot depend on us
+M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: hashtable hashcode*
+ [
+ dup assoc-size 1 number=
+ [ assoc-hashcode ] [ nip assoc-size ] if
+ ] recursive-hashcode ;
-USING: arrays compiler.units kernel kernel.private math
+USING: accessors arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private
[ 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
IN: compiler.tests
-USING: compiler compiler.units tools.test math parser kernel
-sequences sequences.private classes.mixin generic definitions
-arrays words assocs ;
+USING: accessors compiler compiler.units tools.test math parser
+kernel sequences sequences.private classes.mixin generic
+definitions arrays words assocs ;
GENERIC: method-redefine-test ( a -- b )
: 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
IN: compiler.tests
-USING: compiler compiler.units tools.test math parser kernel
-sequences sequences.private classes.mixin generic definitions
-arrays words assocs ;
+USING: accessors compiler compiler.units tools.test math parser
+kernel sequences sequences.private classes.mixin generic
+definitions arrays words assocs ;
GENERIC: sheeple ( obj -- x )
: 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 accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
] unit-test
] times
! Black box testing of templating optimization
-USING: arrays compiler kernel kernel.private math
+USING: accessors arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
0 swap hellish-bug-2 drop ;
[ ] [
- H{ { 1 2 } { 3 4 } } dup hash-array
+ H{ { 1 2 } { 3 4 } } dup array>>
[ 0 swap hellish-bug-2 drop ] compile-call
] unit-test
[ 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
[ T{ color f 1 2 3 } ]
[ 1 2 3 [ color boa ] compile-call ] unit-test
-[ 1 3 ] [
- 1 2 3 color boa
- [ { color-red color-blue } get-slots ] compile-call
-] unit-test
-
-[ T{ color f 10 2 20 } ] [
- 10 20
- 1 2 3 color boa [
- [
- { set-color-red set-color-blue } set-slots
- ] compile-call
- ] keep
-] unit-test
-
[ T{ color f f f f } ]
[ [ color new ] compile-call ] 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
{ +clobber+ { "n" } }
} define-intrinsic
-\ <tuple> [
- tuple "layout" get layout-size 2 + cells %allot
+\ (tuple) [
+ 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
! 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
: generate-write-barrier ( -- )
#! Mark the card pointed to by vreg.
"val" get operand-immediate? "obj" get fresh-object? or [
+ "obj" operand PUSH
+
! Mark the card
"obj" operand card-bits SHR
"cards_offset" f temp-reg v>operand %alien-global
"obj" operand deck-bits card-bits - SHR
"decks_offset" f temp-reg v>operand %alien-global
temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
+
+ "obj" operand POP
] unless ;
\ set-slot {
{
[ %slot-any "val" operand MOV generate-write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
- { +clobber+ { "obj" "n" } }
+ { +clobber+ { "n" } }
}
}
} define-intrinsics
{ +clobber+ { "n" } }
} define-intrinsic
-\ <tuple> [
- tuple "layout" get layout-size 2 + cells [
+\ (tuple) [
+ 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 [
- 2 + object@ f v>operand MOV
- ] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] %allot
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic hashtables inspector io kernel
-math namespaces prettyprint prettyprint.config sequences assocs
-sequences.private strings io.styles vectors words system
+USING: slots arrays definitions generic hashtables inspector io
+kernel math namespaces prettyprint prettyprint.config sequences
+assocs sequences.private strings io.styles vectors words system
splitting math.parser classes.tuple continuations
-continuations.private combinators generic.math
-classes.builtin classes compiler.units generic.standard vocabs
-threads threads.private init kernel.private libc io.encodings
-mirrors accessors math.order destructors ;
+continuations.private combinators generic.math classes.builtin
+classes compiler.units generic.standard vocabs threads
+threads.private init kernel.private libc io.encodings mirrors
+accessors math.order destructors ;
IN: debugger
GENERIC: error. ( error -- )
M: no-method error.
"Generic word " write
- dup no-method-generic pprint
+ dup generic>> pprint
" does not define a method for the " write
- dup no-method-object class pprint
+ dup object>> class pprint
" class." print
- "Allowed classes: " write dup no-method-generic order .
- "Dispatching on object: " write no-method-object short. ;
+ "Dispatching on object: " write object>> short. ;
+
+M: bad-slot-value summary drop "Bad store to specialized slot" ;
M: no-math-method summary
drop "No suitable arithmetic method" ;
M: not-a-tuple summary
drop "Not a tuple" ;
-M: not-a-tuple-class summary
- drop "Not a tuple class" ;
-
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;
M: decode-error summary drop "Character decoding error" ;
-M: no-such-slot summary drop "No such slot" ;
-
-M: immutable-slot summary drop "Slot is immutable" ;
-
M: bad-create summary drop "Bad parameters to create" ;
M: attempt-all-error summary drop "Nothing to attempt" ;
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
#! temp then temp to the destination.
temp-reg over %move
operand-class temp-reg
- { set-operand-class set-tagged-vreg } tagged construct
+ tagged new
+ swap >>vreg
+ swap >>class
%move ;
: %move ( dst src -- )
-USING: alien arrays definitions generic generic.standard
+USING: accessors alien arrays definitions generic generic.standard
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
quotations classes classes.algebra continuations layouts
[ t ] [
\ / usage [ word? ] filter
- [ word-name "generic-forget-test-1/integer" = ] contains?
+ [ name>> "integer=>generic-forget-test-1" = ] contains?
] unit-test
[ ] [
[ f ] [
\ / usage [ word? ] filter
- [ word-name "generic-forget-test-1/integer" = ] contains?
+ [ name>> "integer=>generic-forget-test-1" = ] contains?
] unit-test
GENERIC: generic-forget-test-2 ( a b -- c )
[ t ] [
\ = usage [ word? ] filter
- [ word-name "generic-forget-test-2/sequence" = ] contains?
+ [ name>> "sequence=>generic-forget-test-2" = ] contains?
] unit-test
[ ] [
[ f ] [
\ = usage [ word? ] filter
- [ word-name "generic-forget-test-2/sequence" = ] contains?
+ [ name>> "sequence=>generic-forget-test-2" = ] 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
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
-: specific-method ( class word -- class )
- order min-class ;
+: specific-method ( class generic -- method/f )
+ tuck order min-class dup [ swap method ] [ 2drop f ] if ;
-GENERIC: effective-method ( ... generic -- method )
+GENERIC: effective-method ( generic -- method )
: next-method-class ( class generic -- class/f )
order [ class<= ] with filter reverse dup length 1 =
: next-method ( class generic -- class/f )
[ next-method-class ] keep method ;
-GENERIC: next-method-quot* ( class generic -- quot )
+GENERIC: next-method-quot* ( class generic combination -- quot )
: next-method-quot ( class generic -- quot )
dup "combination" word-prop next-method-quot* ;
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 ;
[
2dup next-method
[ 2nip 1quotation ]
- [ [ no-next-method ] 2curry ] if* ,
+ [ [ no-next-method ] 2curry [ ] like ] if* ,
]
[ [ inconsistent-next-method ] 2curry , ]
2tri
accessors ;
IN: grouping
-TUPLE: abstract-groups seq n ;
+TUPLE: abstract-groups { seq read-only } { n read-only } ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
$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 ;
+ (>>length) ;
: 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
+ over 1 fixnum+fast over (>>length)
] [
>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 (>>length)
] 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
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors optimizer.math.partial accessors
-optimizer.inlining math.order ;
+optimizer.inlining math.order hashtables classes ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
[ 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 )
\ detect-integer inlined?
] unit-test
+[ t ] [
+ [ hashtable new ] \ new inlined?
+] unit-test
+
+[ t ] [
+ [ dup hashtable eq? [ new ] when ] \ new inlined?
+] unit-test
+
+[ t ] [
+ [ hashtable instance? ] \ instance? inlined?
+] unit-test
+
+TUPLE: declared-fixnum { x fixnum } ;
+
+[ t ] [
+ [ { declared-fixnum } declare [ 1 + ] change-x ]
+ { + fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { declared-fixnum } declare x>> drop ]
+ { slot } inlined?
+] unit-test
+
! Later
! [ t ] [
-USING: arrays generic inference inference.backend
+USING: accessors arrays generic inference inference.backend
inference.dataflow kernel classes kernel.private math
math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test
: #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
\ define-tuple-class must-infer
\ define-union-class must-infer
\ define-predicate-class must-infer
+\ instance? must-infer
+\ next-method-quot must-infer
! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
! 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
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
\ <tuple> make-flushable
+\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
+\ (tuple) make-flushable
+
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
\ <tuple-layout> make-foldable
$nl
"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
{ $code "\\ cond [ cond>quot ] 1 define-transform" } } ;
-
-HELP: duplicated-slots-error
-{ $values { "names" "a sequence of setter words" } }
-{ $description "Throws a " { $link duplicated-slots-error } "." }
-{ $error-description "Thrown by stack effect inference if a " { $link set-slots } " form is given an array of slot setters that includes duplicates. Since writing to the same slot multiple times has no useful effect, this is a programmer error, so it is caught at compile time." } ;
[ 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
[ bad-new-test ] must-infer
-[ bad-new-test ] [ T{ not-a-tuple-class f V{ } } = ] must-fail-with
+[ bad-new-test ] must-fail
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel words sequences generic math namespaces
-quotations assocs combinators math.bitfields inference.backend
-inference.dataflow inference.state classes.tuple
-classes.tuple.private effects inspector hashtables classes
-generic sets definitions ;
+USING: accessors arrays kernel words sequences generic math
+namespaces quotations assocs combinators math.bitfields
+inference.backend inference.dataflow inference.state
+classes.tuple classes.tuple.private effects inspector hashtables
+classes generic sets definitions generic.standard slots.private ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
\ boa [
dup tuple-class? [
dup +inlined+ depends-on
- tuple-layout [ <tuple-boa> ] curry
+ [ "boa-check" word-prop ]
+ [ tuple-layout [ <tuple-boa> ] curry ]
+ bi append
] [
- [ not-a-tuple-class ] curry time-bomb
+ \ boa \ no-method boa time-bomb
] if
] 1 define-transform
-\ new [
- 1 ensure-values
- peek-d value? [
- pop-literal dup tuple-class? [
- dup +inlined+ depends-on
- tuple-layout [ <tuple> ] curry
- swap infer-quot
- ] [
- \ not-a-tuple-class boa time-bomb drop
- ] if
- ] [
- \ new (( class -- tuple )) make-call-node
- ] if
-] "infer" set-word-prop
+: [tuple-boa] ( layout -- quot )
+ [ [ (tuple) ] curry ]
+ [
+ size>> 1 - [ 3 + ] map <reversed>
+ [ [ set-slot ] curry [ keep ] curry ] map concat
+ ] bi
+ [ f over 2 set-slot ]
+ 3append ;
-\ instance? [
- [ +inlined+ depends-on ] [ "predicate" word-prop ] bi
-] 1 define-transform
+\ <tuple-boa> [ [tuple-boa] ] 1 define-transform
\ (call-next-method) [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
! 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" %
: summary. ( obj -- ) [ summary ] keep write-object nl ;
: sorted-keys ( assoc -- alist )
- dup mirror? [ keys ] [
+ dup hashtable? [
keys
[ [ unparse-short ] keep ] { } map>assoc
sort-keys values
- ] if ;
+ ] [ keys ] if ;
: describe* ( obj flags -- )
clone [
-! 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
M: callstack clone (clone) ;
! Tuple construction
-: new ( class -- tuple )
- tuple-layout <tuple> ;
+GENERIC: new ( class -- tuple )
-: boa ( ... class -- tuple )
- tuple-layout <tuple-boa> ;
+GENERIC: boa ( ... class -- tuple )
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )
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 -- )
{ $subsection max-array-capacity } ;
ARTICLE: "layouts-bootstrap" "Bootstrap support"
-"Bootstrap support:"
+"Processor cell size for the target architecture:"
{ $subsection bootstrap-cell }
{ $subsection bootstrap-cells }
{ $subsection bootstrap-cell-bits }
+"Range of integers representable by " { $link fixnum } "s of the target architecture:"
{ $subsection bootstrap-most-negative-fixnum }
-{ $subsection bootstrap-most-positive-fixnum } ;
+{ $subsection bootstrap-most-positive-fixnum }
+"Maximum array size for the target architecture:"
+{ $subsection bootstrap-max-array-capacity } ;
ARTICLE: "layouts" "VM memory layouts"
"The words documented in this section do not ever need to be called by user code. They are documented for the benefit of those wishing to explore the internals of Factor's implementation."
\r
[ t ] [ cell integer? ] unit-test\r
[ t ] [ bootstrap-cell integer? ] unit-test\r
+\r
+! Smoke test\r
+[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test\r
: most-negative-fixnum ( -- n )
first-bignum neg ;
+: (max-array-capacity) ( b -- n )
+ 5 - 2^ 1- ;
+
+: max-array-capacity ( -- n )
+ cell-bits (max-array-capacity) ;
+
: bootstrap-first-bignum ( -- n )
bootstrap-cell-bits (first-bignum) ;
: bootstrap-most-negative-fixnum ( -- n )
bootstrap-first-bignum neg ;
+: bootstrap-max-array-capacity ( -- n )
+ bootstrap-cell-bits (max-array-capacity) ;
+
M: bignum >integer
dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] when ;
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.
-USING: math math.bitfields tools.test kernel words ;
+USING: accessors math math.bitfields tools.test kernel words ;
IN: math.bitfields.tests
[ 0 ] [ { } bitfield ] unit-test
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
-[ t ] [ \ foo compiled? ] unit-test
+\ foo must-infer
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
-USING: kernel sequences arrays math combinators math.order ;
+USING: accessors kernel sequences arrays math math.order
+combinators ;
IN: math.intervals
-TUPLE: interval from to ;
+TUPLE: interval { from read-only } { to read-only } ;
C: <interval> interval
: closed-point ( n -- endpoint ) t 2array ;
: [a,b] ( a b -- interval )
- >r closed-point r> closed-point <interval> ;
+ >r closed-point r> closed-point <interval> ; foldable
: (a,b) ( a b -- interval )
- >r open-point r> open-point <interval> ;
+ >r open-point r> open-point <interval> ; foldable
: [a,b) ( a b -- interval )
- >r closed-point r> open-point <interval> ;
+ >r closed-point r> open-point <interval> ; foldable
: (a,b] ( a b -- interval )
- >r open-point r> closed-point <interval> ;
+ >r open-point r> closed-point <interval> ; foldable
-: [a,a] ( a -- interval ) closed-point dup <interval> ;
+: [a,a] ( a -- interval )
+ closed-point dup <interval> ; foldable
-: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ;
+: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline
-: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ;
+: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline
-: [a,inf] ( a -- interval ) 1./0. [a,b] ;
+: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline
-: (a,inf] ( a -- interval ) 1./0. (a,b] ;
+: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
: compare-endpoints ( p1 p2 quot -- ? )
>r over first over first r> call [
: endpoint-max ( p1 p2 -- p3 ) [ endpoint> ] most ;
: interval>points ( int -- from to )
- dup interval-from swap interval-to ;
+ [ from>> ] [ to>> ] bi ;
: points>interval ( seq -- interval )
dup first
r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 )
- pick interval-from pick interval-from pick (interval-op) >r
- pick interval-to pick interval-from pick (interval-op) >r
- pick interval-to pick interval-to pick (interval-op) >r
- pick interval-from pick interval-to pick (interval-op) >r
- 3drop r> r> r> r> 4array points>interval ; inline
+ {
+ [ [ from>> ] [ from>> ] [ ] tri* (interval-op) ]
+ [ [ to>> ] [ from>> ] [ ] tri* (interval-op) ]
+ [ [ to>> ] [ to>> ] [ ] tri* (interval-op) ]
+ [ [ from>> ] [ to>> ] [ ] tri* (interval-op) ]
+ } 3cleave 4array points>interval ; inline
: interval+ ( i1 i2 -- i3 ) [ + ] interval-op ;
[ [ shift ] interval-op ] interval-integer-op interval-closure ;
: interval-shift-safe ( i1 i2 -- i3 )
- dup interval-to first 100 > [
+ dup to>> first 100 > [
2drop f
] [
interval-shift
: left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ] 2keep
[ nip interval-singleton? ] 2keep
- [ interval-from ] bi@ =
+ [ from>> ] bi@ =
and and ;
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ] 2keep
[ drop interval-singleton? ] 2keep
- [ interval-to ] bi@ =
+ [ to>> ] bi@ =
and and ;
: (interval<) ( i1 i2 -- i1 i2 ? )
- over interval-from over interval-from endpoint< ;
+ over from>> over from>> endpoint< ;
: interval< ( i1 i2 -- ? )
{
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
- >r interval-from r> interval-to = ;
+ >r from>> r> to>> = ;
: right-endpoint-<= ( i1 i2 -- ? )
- >r interval-to r> interval-from = ;
+ >r to>> r> from>> = ;
: interval<= ( i1 i2 -- ? )
{
swap interval<= ;
: assume< ( i1 i2 -- i3 )
- interval-to first [-inf,a) interval-intersect ;
+ to>> first [-inf,a) interval-intersect ;
: assume<= ( i1 i2 -- i3 )
- interval-to first [-inf,a] interval-intersect ;
+ to>> first [-inf,a] interval-intersect ;
: assume> ( i1 i2 -- i3 )
- interval-from first (a,inf] interval-intersect ;
+ from>> first (a,inf] interval-intersect ;
: assume>= ( i1 i2 -- i3 )
- interval-to first [a,inf] interval-intersect ;
+ to>> first [a,inf] interval-intersect ;
: integral-closure ( i1 -- i2 )
- dup interval-from first2 [ 1+ ] unless
- swap interval-to first2 [ 1- ] unless
- [a,b] ;
+ [ from>> first2 [ 1+ ] unless ]
+ [ to>> first2 [ 1- ] unless ]
+ bi [a,b] ;
{ $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 ;
ABOUT: "mirrors"
-HELP: object-slots
-{ $values { "obj" object } { "seq" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Outputs a sequence of slot specifiers for the object." } ;
-
HELP: mirror
{ $class-description "An associative structure which wraps an object and presents itself as a mapping from slot names to the object's slot values. Mirrors are used to build reflective developer tools."
$nl
-USING: mirrors tools.test assocs kernel arrays accessors ;
+USING: mirrors tools.test assocs kernel arrays accessors words
+namespaces math slots ;
IN: mirrors.tests
TUPLE: foo bar baz ;
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
] unit-test
-[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
- [ no-such-slot? ]
- [ name>> "hi" = ]
- [ object>> foo? ] tri and and
-] must-fail-with
-
-[ 3 "numerator" 1/2 <mirror> set-at ] [
- [ immutable-slot? ]
- [ name>> "numerator" = ]
- [ object>> 1/2 = ] tri and and
-] must-fail-with
+[ 3 "hi" 1 2 <foo> <mirror> set-at ] must-fail
+
+[ 3 "numerator" 1/2 <mirror> set-at ] must-fail
+
+[ "foo" ] [
+ gensym [
+ <mirror> [
+ "foo" "name" set
+ ] bind
+ ] [ name>> ] bi
+] unit-test
+
+[ gensym <mirror> [ "compiled" off ] bind ] must-fail
+
+TUPLE: declared-mirror-test
+{ a integer initial: 0 } ;
+
+[ 5 ] [
+ 3 declared-mirror-test boa <mirror> [
+ 5 "a" set
+ "a" get
+ ] bind
+] unit-test
+
+[ 3 declared-mirror-test boa <mirror> [ t "a" set ] bind ] must-fail
+
+TUPLE: color
+{ red integer }
+{ green integer }
+{ blue integer } ;
+
+[ T{ color f 0 0 0 } ] [
+ 1 2 3 color boa [ <mirror> clear-assoc ] keep
+] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple math vectors
-quotations accessors ;
+quotations accessors combinators ;
IN: mirrors
-: all-slots ( class -- slots )
- superclasses [ "slots" word-prop ] map concat ;
-
-: object-slots ( obj -- seq )
- class all-slots ;
-
-TUPLE: mirror object slots ;
+TUPLE: mirror { object read-only } { slots read-only } ;
: <mirror> ( object -- mirror )
- dup object-slots mirror boa ;
-
-ERROR: no-such-slot object name ;
-
-ERROR: immutable-slot object name ;
+ dup class all-slots mirror boa ;
M: mirror at*
[ nip object>> ] [ slots>> slot-named ] 2bi
dup [ offset>> slot t ] [ 2drop f f ] if ;
+: check-set-slot ( val slot -- val offset )
+ {
+ { [ dup not ] [ "No such slot" throw ] }
+ { [ dup read-only>> ] [ "Read only slot" throw ] }
+ { [ 2dup class>> instance? not ] [ class>> bad-slot-value ] }
+ [ offset>> ]
+ } cond ; inline
+
M: mirror set-at ( val key mirror -- )
- [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
- dup writer>> [
- nip offset>> set-slot
- ] [
- drop immutable-slot
- ] if
- ] [
- drop no-such-slot
- ] if ;
+ [ slots>> slot-named check-set-slot ] [ object>> ] bi
+ swap set-slot ;
M: mirror delete-at ( key mirror -- )
f -rot set-at ;
+M: mirror clear-assoc ( mirror -- )
+ [ object>> ] [ slots>> ] bi [
+ [ initial>> ] [ offset>> ] bi swapd set-slot
+ ] with each ;
+
M: mirror >alist ( mirror -- alist )
[ slots>> [ name>> ] map ]
[ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
+USING: accessors inference inference.dataflow optimizer
+optimizer.def-use namespaces assocs kernel sequences math
+tools.test words sets ;
IN: optimizer.def-use.tests
-USING: inference inference.dataflow optimizer optimizer.def-use
-namespaces assocs kernel sequences math tools.test words sets ;
[ 3 { 1 1 1 } ] [
[ 1 2 3 ] dataflow compute-def-use drop
{
[ 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
IN: optimizer.inlining.tests
-USING: tools.test optimizer.inlining ;
+USING: tools.test optimizer.inlining generic arrays math
+sequences growable sbufs vectors sequences.private accessors kernel ;
\ word-flat-length must-infer
-
\ inlining-math-method must-infer
-
\ optimistic-inline? must-infer
-
\ find-identity must-infer
+\ dispatching-class must-infer
+
+! Make sure we have sane heuristics
+: should-inline? ( generic class -- ? ) method flat-length 10 <= ;
+
+[ t ] [ \ fixnum \ shift should-inline? ] unit-test
+[ f ] [ \ array \ equal? should-inline? ] unit-test
+[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
+[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
+[ t ] [ \ growable \ set-nth-unsafe should-inline? ] unit-test
+[ t ] [ \ vector \ (>>length) should-inline? ] 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
! heuristic: { ... } declare comes up in method bodies
! and we don't care about it
{ [ dup \ declare eq? ] [ drop -2 ] }
- ! recursive
- { [ dup get ] [ drop 1 ] }
! not inline
{ [ dup inline? not ] [ drop 1 ] }
+ ! recursive and inline
+ { [ dup get ] [ drop 1 ] }
! inline
- [ dup dup set word-def (flat-length) ]
+ [ dup dup set def>> (flat-length) ]
} cond ;
: (flat-length) ( seq -- n )
} cond
] map sum ;
-: flat-length ( seq -- n )
- [ word-def (flat-length) ] with-scope ;
+: flat-length ( word -- n )
+ [ def>> (flat-length) ] with-scope ;
! Single dispatch method inlining optimization
-: node-class# ( node n -- class )
- over node-in-d <reversed> ?nth node-class ;
+! : dispatching-class ( node generic -- method/f )
+! tuck dispatch# over in-d>> <reversed> ?nth 2dup node-literal?
+! [ node-literal swap single-effective-method ]
+! [ node-class swap specific-method ]
+! if ;
-: dispatching-class ( node word -- class )
- [ dispatch# node-class# ] keep specific-method ;
+: dispatching-class ( node generic -- method/f )
+ tuck dispatch# over in-d>> <reversed> ?nth
+ node-class swap specific-method ;
-: inline-standard-method ( node word -- node )
- 2dup dispatching-class dup
- [ swap method 1quotation f splice-quot ] [ 3drop t ] if ;
+: inline-standard-method ( node generic -- node )
+ dupd dispatching-class dup
+ [ 1quotation f splice-quot ] [ 2drop t ] if ;
! Partial dispatch of math-generic words
: normalize-math-class ( class -- 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
-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
-io.streams.string layouts splitting math.intervals
-math.floats.private classes.tuple classes.tuple.private classes
-classes.algebra optimizer.def-use optimizer.backend
-optimizer.pattern-match optimizer.inlining float-arrays
-sequences.private combinators byte-arrays byte-vectors ;
-
-{ <tuple> <tuple-boa> } [
+USING: accessors alien arrays generic hashtables definitions
+inference.dataflow inference.state 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 io.streams.string layouts splitting
+math.intervals math.floats.private classes.tuple classes.predicate
+classes.tuple.private classes classes.algebra optimizer.def-use
+optimizer.backend optimizer.pattern-match optimizer.inlining
+float-arrays sequences.private combinators byte-arrays
+byte-vectors ;
+
+{ <tuple> <tuple-boa> (tuple) } [
[
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
dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop
+! if the input to new is a literal tuple class, we can expand it
+: literal-new? ( #call -- ? )
+ dup in-d>> first node-literal tuple-class? ;
+
+: new-quot ( class -- quot )
+ dup all-slots 1 tail ! delegate slot
+ [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
+
+: expand-new ( #call -- node )
+ dup dup in-d>> first node-literal
+ [ +inlined+ depends-on ] [ new-quot ] bi
+ f splice-quot ;
+
+\ new {
+ { [ dup literal-new? ] [ expand-new ] }
+} define-optimizers
+
! the output of clone has the same type as the input
{ clone (clone) } [
[
] if
] "constraints" set-word-prop
+! open-code instance? checks on predicate classes
+: literal-predicate-class? ( #call -- ? )
+ dup in-d>> second node-literal predicate-class? ;
+
+: expand-predicate-instance ( #call -- node )
+ dup dup in-d>> second node-literal
+ [ +inlined+ depends-on ]
+ [ "predicate-definition" word-prop [ drop ] prepose ] bi
+ f splice-quot ;
+
+\ predicate-instance? {
+ { [ dup literal-predicate-class? ] [ expand-predicate-instance ] }
+} define-optimizers
+
! eq? on the same object is always t
{ eq? = } {
{ { @ @ } [ 2drop t ] }
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
-USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer generator prettyprint sequences
-sbufs strings tools.test vectors words sequences.private
-quotations optimizer.backend classes classes.algebra
-inference.dataflow classes.tuple.private continuations growable
-optimizer.inlining namespaces hints ;
+USING: accessors arrays compiler.units generic hashtables
+inference kernel kernel.private math optimizer generator
+prettyprint sequences sbufs strings tools.test vectors words
+sequences.private quotations optimizer.backend classes
+classes.algebra inference.dataflow classes.tuple.private
+continuations growable optimizer.inlining namespaces hints ;
IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
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 ;
M: integer foozul ;
M: slice foozul ;
-[ reversed ] [ reversed \ foozul specific-method ] unit-test
+[ t ] [
+ reversed \ foozul specific-method
+ reversed \ foozul method
+ eq?
+] unit-test
! regression
: constant-fold-2 f ; foldable
: 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
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
-! Make sure we have sane heuristics
-: should-inline? ( generic class -- ? ) method flat-length 10 <= ;
-
-[ t ] [ \ fixnum \ shift should-inline? ] unit-test
-[ f ] [ \ array \ equal? should-inline? ] unit-test
-[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
-[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
-[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
-[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
-
! Regression
: lift-throw-tail-regression ( obj -- obj str )
dup integer? [ "an integer" ] [
] 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
[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
[ t ] [ \ + member-test ] unit-test
[ f ] [ \ append member-test ] unit-test
+
+! Infinite expansion
+TUPLE: cons car cdr ;
+
+UNION: improper-list cons POSTPONE: f ;
+
+PREDICATE: list < improper-list
+ [ cdr>> list instance? ] [ t ] if* ;
+
+[ t ] [
+ T{ cons f 1 T{ cons f 2 T{ cons f 3 f } } }
+ [ list instance? ] compile-call
+] unit-test
! 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 ;
] keep =
] with-scope ;
-: method-test
+GENERIC: method-layout
+
+M: complex method-layout
+ "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ ;
+
+M: fixnum method-layout ;
+
+M: integer method-layout ;
+
+M: object method-layout ;
+
+[
{
- "IN: prettyprint.tests"
- "GENERIC: method-layout"
- ""
"USING: math prettyprint.tests ;"
"M: complex method-layout"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
""
"USING: kernel prettyprint.tests ;"
"M: object method-layout ;"
- } ;
-
-[ t ] [
- "method-layout" method-test check-see
+ ""
+ }
+] [
+ [ \ method-layout see-methods ] with-string-writer "\n" split
] unit-test
: retain-stack-test
"another-narrow-layout" another-narrow-test check-see
] unit-test
-: class-see-test
+IN: prettyprint.tests
+TUPLE: class-see-layout ;
+
+IN: prettyprint.tests
+GENERIC: class-see-layout ( x -- y )
+
+USING: prettyprint.tests ;
+M: class-see-layout class-see-layout ;
+
+[
{
"IN: prettyprint.tests"
"TUPLE: class-see-layout ;"
"IN: prettyprint.tests"
"GENERIC: class-see-layout ( x -- y )"
""
+ }
+] [
+ [ \ class-see-layout see ] with-string-writer "\n" split
+] unit-test
+
+[
+ {
"USING: prettyprint.tests ;"
"M: class-see-layout class-see-layout ;"
- } ;
-
-[ t ] [
- "class-see-layout" class-see-test check-see
+ ""
+ }
+] [
+ [ \ class-see-layout see-methods ] with-string-writer "\n" split
] unit-test
[ ] [ \ effect-in synopsis drop ] unit-test
"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.
{
M: singleton-class see-class* ( class -- )
\ SINGLETON: pprint-word pprint-word ;
+GENERIC: pprint-slot-name ( object -- )
+
+M: string pprint-slot-name text ;
+
+M: array pprint-slot-name
+ <flow \ { pprint-word
+ f <inset unclip text pprint-elements block>
+ \ } pprint-word block> ;
+
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
- slot-names [ text ] each
+ <block slot-names [ pprint-slot-name ] each block>
pprint-; block> ;
M: word see-class* drop ;
M: builtin-class see-class*
drop "! Built-in class" comment. ;
-: see-all ( seq -- )
- natural-sort [ nl see ] each ;
-
-: see-implementors ( class -- seq )
- dup implementors
- [ method ] with map
- natural-sort ;
-
: see-class ( class -- )
dup class? [
[
] with-use nl
] when drop ;
-: see-methods ( generic -- seq )
- "methods" word-prop values natural-sort ;
-
M: word see
dup see-class
dup class? over symbol? not and [
dup class? over symbol? and not [
[ dup (see) ] with-use nl
] when
+ drop ;
+
+: see-all ( seq -- )
+ natural-sort [ nl ] [ see ] interleave ;
+
+: (see-implementors) ( class -- seq )
+ dup implementors [ method ] with map natural-sort ;
+
+: (see-methods) ( generic -- seq )
+ "methods" word-prop values natural-sort ;
+
+: see-methods ( word -- )
[
- dup class? [ dup see-implementors % ] when
- dup generic? [ dup see-methods % ] when
+ dup class? [ dup (see-implementors) % ] when
+ dup generic? [ dup (see-methods) % ] when
drop
] { } make prune see-all ;
: <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
USING: arrays bit-arrays help.markup help.syntax math
-sequences.private vectors strings sbufs kernel math.order ;
+sequences.private vectors strings sbufs kernel math.order
+layouts ;
IN: sequences
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
HELP: array-capacity
{ $values { "array" "an array" } { "n" "a non-negative fixnum" } }
+{ $class-description "A predicate class whose instances are valid array sizes for the current architecture. The minimum value is zero and the maximum value is " { $link max-array-capacity } "." }
{ $description "Low-level array length accessor." }
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types, so improper use can corrupt memory." } ;
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private slots.private math math.private
-math.order ;
+USING: accessors kernel kernel.private slots.private math
+math.private math.order ;
IN: sequences
MIXIN: sequence
<PRIVATE
-: max-array-capacity ( -- n )
- #! A bit of a pain; can't call cell-bits here
- 7 getenv 8 * 5 - 2^ 1- ; foldable
-
-PREDICATE: array-capacity < fixnum
- 0 max-array-capacity between? ;
-
: array-capacity ( array -- n )
1 slot { array-capacity } declare ; inline
INSTANCE: virtual-sequence sequence
! A reversal of an underlying sequence.
-TUPLE: reversed seq ;
+TUPLE: reversed { seq read-only } ;
C: <reversed> reversed
-M: reversed virtual-seq reversed-seq ;
+M: reversed virtual-seq seq>> ;
-M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
+M: reversed virtual@ seq>> [ length swap - 1- ] keep ;
-M: reversed length reversed-seq length ;
+M: reversed length seq>> length ;
INSTANCE: reversed virtual-sequence
: reverse ( seq -- newseq ) [ <reversed> ] [ like ] bi ;
! A slice of another sequence.
-TUPLE: slice from to seq ;
+TUPLE: slice
+{ from read-only }
+{ to read-only }
+{ seq read-only } ;
: collapse-slice ( m n slice -- m' n' seq )
- dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
+ [ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline
ERROR: slice-error reason ;
check-slice
slice boa ; inline
-M: slice virtual-seq slice-seq ;
+M: slice virtual-seq seq>> ;
-M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ;
+M: slice virtual@ [ from>> + ] [ seq>> ] bi ;
-M: slice length dup slice-to swap slice-from - ;
+M: slice length [ to>> ] [ from>> ] bi - ;
: short ( seq n -- seq n' ) over length min ; inline
INSTANCE: slice virtual-sequence
! One element repeated many times
-TUPLE: repetition len elt ;
+TUPLE: repetition { len read-only } { elt read-only } ;
C: <repetition> repetition
-M: repetition length repetition-len ;
-M: repetition nth-unsafe nip repetition-elt ;
+M: repetition length len>> ;
+M: repetition nth-unsafe nip elt>> ;
INSTANCE: repetition immutable-sequence
! 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
swap "declared-effect" set-word-prop\r
slot-spec-reader swap "reading" set-word-prop ;\r
\r
+: define-slot-word ( class word quot -- )\r
+ [\r
+ dup define-simple-generic\r
+ create-method\r
+ ] dip define ;\r
+\r
: define-reader ( class spec -- )\r
dup slot-spec-reader [\r
[ set-reader-props ] 2keep\r
- dup slot-spec-offset\r
- over slot-spec-reader\r
- rot slot-spec-type reader-quot\r
+ dup slot-spec-reader\r
+ swap reader-quot\r
define-slot-word\r
] [\r
2drop\r
: define-writer ( class spec -- )\r
dup slot-spec-writer [\r
[ set-writer-props ] 2keep\r
- dup slot-spec-offset\r
- swap slot-spec-writer\r
- [ set-slot ]\r
+ dup slot-spec-writer\r
+ swap writer-quot\r
define-slot-word\r
] [\r
2drop\r
>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
IN: slots
ARTICLE: "accessors" "Slot accessors"
-"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:"
-{ $list
- { "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." }
- { "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." }
-}
-"In addition, two utility words are defined for each distinct slot name used in the system:"
-{ $list
- { "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
- { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
-}
+"For every tuple slot, a " { $emphasis "reader" } " method is defined in the " { $vocab-link "accessors" } " vocabulary. The reader is named " { $snippet { $emphasis "slot" } ">>" } " and given a tuple, pushes the slot value on the stack."
+$nl
+"Writable slots - that is, those not attributed " { $link read-only } " - also have a " { $emphasis "writer" } ". The writer is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } ". If the slot is specialized to a specific class, the writer checks that the value being written into the slot is an instance of that class first."
+$nl
+"In addition, two utility words are defined for each writable slot."
+$nl
+"The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "."
+$nl
+"The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "."
+$nl
"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."
$nl
"In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:"
$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 not. Read only slots do not have a writer method associated with them." }
} } ;
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." } ;
-
-HELP: define-slot-word
-{ $values { "class" class } { "slot" "a positive integer" } { "word" word } { "quot" quotation } }
-{ $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." }
-$low-level-note ;
+{ $notes "This word is used internally to wrap unsafe low-level code in a type-checking stub." } ;
HELP: define-reader
{ $values { "class" class } { "name" string } { "slot" integer } }
--- /dev/null
+IN: slots.tests
+USING: math accessors slots strings generic.standard kernel
+tools.test generic words parser ;
+
+TUPLE: r/w-test foo ;
+
+TUPLE: r/o-test { foo read-only } ;
+
+[ 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
+
+[ t ] [ r/o-test \ foo>> method "foldable" word-prop ] unit-test
+[ t ] [ r/o-test \ foo>> method "flushable" word-prop ] unit-test
+
+[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
+[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
+
+! See if declarations are cleared on redefinition
+[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test
+
+[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
+[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
+
+[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test
+
+[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
+[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
! Copyright (C) 2005, 2008 Slava Pestov.
! 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 ;
+USING: arrays bit-arrays byte-arrays float-arrays kernel
+kernel.private math namespaces sequences strings words effects
+generic generic.standard classes classes.algebra slots.private
+combinators accessors words sequences.private assocs ;
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 -- )
- over define-simple-generic
- >r create-method r> define ;
+: define-typecheck ( class generic quot props -- )
+ [ dup define-simple-generic create-method ] 2dip
+ [ [ props>> ] [ drop ] [ [ t ] H{ } map>assoc ] tri* update ]
+ [ drop define ]
+ 3bi ;
-: define-slot-word ( class slot 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 )
+: reader-quot ( slot-spec -- quot )
[
+ dup offset>> ,
\ slot ,
- dup object bootstrap-word eq?
- [ drop ] [ 1array , \ declare , ] if
+ dup class>> object bootstrap-word eq?
+ [ drop ] [ class>> 1array , \ declare , ] if
] [ ] make ;
-: 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 -- )
- reader-word object reader-quot define-slot-word ;
+: reader-props ( slot-spec -- seq )
+ read-only>> { "foldable" "flushable" } { "flushable" } ? ;
+
+: define-reader ( class slot-spec -- )
+ [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
+ define-typecheck ;
: writer-word ( name -- word )
"(>>" swap ")" 3append (( value object -- )) create-accessor ;
-: define-writer ( class slot name -- )
- writer-word [ set-slot ] define-slot-word ;
+ERROR: bad-slot-value value class ;
+
+: writer-quot/object ( slot-spec -- )
+ offset>> , \ set-slot , ;
+
+: writer-quot/coerce ( slot-spec -- )
+ [ \ >r , class>> "coercer" word-prop % \ r> , ]
+ [ offset>> , \ set-slot , ]
+ bi ;
+
+: writer-quot/check ( slot-spec -- )
+ [ offset>> , ]
+ [
+ \ pick ,
+ dup class>> "predicate" word-prop %
+ [ set-slot ] ,
+ class>> [ 2nip bad-slot-value ] curry [ ] like ,
+ \ if ,
+ ]
+ bi ;
+
+: writer-quot/fixnum ( slot-spec -- )
+ [ >r >fixnum r> ] % writer-quot/check ;
+
+: writer-quot ( slot-spec -- quot )
+ [
+ {
+ { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
+ { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
+ { [ dup class>> fixnum bootstrap-word class<= ] [ writer-quot/fixnum ] }
+ [ writer-quot/check ]
+ } cond
+ ] [ ] make ;
+
+: define-writer ( class slot-spec -- )
+ [ name>> writer-word ] [ writer-quot ] bi { } define-typecheck ;
: 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 ,
] [ ] make define-inline
] [ 2drop ] if ;
-: define-slot-methods ( class slot name -- )
- dup define-changer
- dup define-setter
- 3dup define-reader
- define-writer ;
+: define-slot-methods ( class slot-spec -- )
+ [ define-reader ]
+ [
+ dup read-only>> [ 2drop ] [
+ [ define-setter drop ]
+ [ define-changer drop ]
+ [ define-writer ]
+ 2tri
+ ] if
+ ] 2bi ;
: define-accessors ( class specs -- )
- [
- dup slot-spec-offset swap slot-spec-name
- define-slot-methods
- ] with each ;
+ [ define-slot-methods ] with each ;
+
+: define-protocol-slot ( name -- )
+ {
+ [ reader-word drop ]
+ [ writer-word drop ]
+ [ setter-word drop ]
+ [ changer-word drop ]
+ } cleave ;
+
+ERROR: no-initial-value class ;
+
+: initial-value ( class -- object )
+ {
+ { [ \ f bootstrap-word over class<= ] [ f ] }
+ { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
+ { [ float bootstrap-word over class<= ] [ 0.0 ] }
+ { [ string bootstrap-word over class<= ] [ "" ] }
+ { [ array bootstrap-word over class<= ] [ { } ] }
+ { [ bit-array bootstrap-word over class<= ] [ ?{ } ] }
+ { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
+ { [ float-array bootstrap-word over class<= ] [ F{ } ] }
+ [ no-initial-value ]
+ } cond nip ;
+
+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? [
+ dup first class? [
+ [ first >>class ] [ rest ] bi
+ ] when
+ ] unless ;
+
+ERROR: bad-slot-attribute key ;
+
+: peel-off-attributes ( slot-spec array -- slot-spec array )
+ dup empty? [
+ unclip {
+ { initial: [ [ first >>initial ] [ rest ] bi ] }
+ { read-only [ [ t >>read-only ] dip ] }
+ [ bad-slot-attribute ]
+ } case
+ ] unless ;
+
+ERROR: bad-initial-value name ;
+
+: check-initial-value ( slot-spec -- slot-spec )
+ dup initial>> [
+ [ ] [
+ dup [ initial>> ] [ class>> ] bi instance?
+ [ name>> bad-initial-value ] unless
+ ] if-bootstrapping
+ ] [
+ dup class>> initial-value >>initial
+ ] if ;
+
+M: array make-slot
+ <slot-spec>
+ swap
+ peel-off-name
+ peel-off-class
+ [ dup empty? not ] [ peel-off-attributes ] [ ] while drop
+ check-initial-value ;
+
+: 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
new-definitions get swap set-source-file-definitions ;
: <source-file> ( path -- source-file )
- <definitions>
- { set-source-file-path set-source-file-definitions }
- \ source-file construct ;
+ \ source-file new
+ swap >>path
+ <definitions> >>definitions ;
: source-file ( path -- source-file )
dup string? [ "Invalid source file path" throw ] unless
! 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" } }
+{ $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." } ;
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
- [ boa ] curry define-inline
+ scan-word [ boa ] curry define-inline
] define-syntax
"ERROR:" [
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 kernel.private math namespaces
+USING: accessors arrays kernel kernel.private math namespaces
sequences sequences.private strings tools.test vectors
continuations random growable classes ;
IN: vectors.tests
[ "funky" ] [ "funny-stack" get pop ] unit-test
[ t ] [
- V{ 1 2 3 4 } dup underlying length
- >r clone underlying length r>
+ V{ 1 2 3 4 } dup underlying>> length
+ >r clone underlying>> length r>
=
] unit-test
[ f ] [
V{ 1 2 3 4 } dup clone
- [ underlying ] bi@ eq?
+ [ underlying>> ] bi@ eq?
] unit-test
[ 0 ] [
USING: arrays kernel math sequences sequences.private growable ;
IN: vectors
+TUPLE: vector
+{ underlying array }
+{ length array-capacity } ;
+
<PRIVATE
: array>vector ( array length -- vector )
! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs strings kernel sorting namespaces sequences
-definitions ;
+USING: accessors assocs strings kernel sorting namespaces
+sequences definitions ;
IN: vocabs
SYMBOL: dictionary
source-loaded? docs-loaded? ;
: <vocab> ( name -- vocab )
- H{ } clone
- { set-vocab-name set-vocab-words }
- \ vocab construct ;
+ \ vocab new
+ swap >>name
+ H{ } clone >>words ;
GENERIC: vocab ( vocab-spec -- vocab )
"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 ;
-USING: words quotations kernel effects sequences parser ;\r
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors words quotations kernel effects sequences parser ;\r
IN: alias\r
\r
PREDICATE: alias < word "alias" word-prop ;\r
[ 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
: minutes-per-year 5259492/10 ; inline
: seconds-per-year 31556952 ; inline
-<PRIVATE
-
-SYMBOL: a
-SYMBOL: b
-SYMBOL: c
-SYMBOL: d
-SYMBOL: e
-SYMBOL: y
-SYMBOL: m
-
-PRIVATE>
-
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel macros sequences slots words mirrors ;
+USING: kernel macros sequences slots words classes.tuple ;
IN: classes.tuple.lib
: reader-slots ( seq -- quot )
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel math sequences words arrays io io.files namespaces
-math.parser assocs quotations parser lexer parser-combinators
-tools.time io.encodings.binary sequences.deep symbols combinators ;
+USING: accessors kernel math sequences words arrays io io.files
+namespaces math.parser assocs quotations parser lexer
+parser-combinators tools.time io.encodings.binary sequences.deep
+symbols combinators ;
IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
[ " 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
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { strip-globals? f }
- { strip-word-props? f }
- { strip-word-names? f }
- { strip-dictionary? f }
- { strip-debugger? f }
- { deploy-math? t }
- { deploy-compiled? t }
- { deploy-io? f }
- { deploy-ui? f }
-}
! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg strings promises sequences math math.parser
- namespaces words quotations arrays hashtables io
- io.streams.string assocs memoize ascii peg.parsers ;
+USING: accessors kernel peg strings promises sequences math
+math.parser namespaces words quotations arrays hashtables io
+io.streams.string assocs memoize ascii peg.parsers ;
IN: fjsc
TUPLE: ast-number value ;
<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' )
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: words kernel sequences splitting ;
+USING: accessors words kernel sequences splitting ;
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 ;
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
quotations io.streams.byte-array io.encodings.string
-classes.builtin parser lexer ;
+classes.builtin parser lexer classes.predicate classes.union
+classes.intersection classes.singleton classes.tuple ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
{ $index [ builtins get sift ] } ;
ARTICLE: "class-index" "Class index"
-{ $index [ classes ] } ;
+{ $heading "Built-in classes" }
+{ $index [ classes [ builtin-class? ] filter ] }
+{ $heading "Tuple classes" }
+{ $index [ classes [ tuple-class? ] filter ] }
+{ $heading "Singleton classes" }
+{ $index [ classes [ singleton-class? ] filter ] }
+{ $heading "Union classes" }
+{ $index [ classes [ union-class? ] filter ] }
+{ $heading "Intersection classes" }
+{ $index [ classes [ intersection-class? ] filter ] }
+{ $heading "Predicate classes" }
+{ $index [ classes [ predicate-class? ] filter ] } ;
ARTICLE: "program-org" "Program organization"
{ $subsection "definitions" }
! 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 -- ? )
{
: all-word-help ( words -- seq )
[ word-help ] filter ;
-TUPLE: help-error topic ;
+TUPLE: help-error topic error ;
-: <help-error> ( topic delegate -- error )
- { set-help-error-topic set-delegate } help-error construct ;
+C: <help-error> help-error
M: help-error error.
- "In " write dup help-error-topic ($link) nl
- delegate error. ;
+ "In " write dup topic>> pprint nl
+ error>> error. ;
: check-something ( obj quot -- )
flush [ <help-error> , ] recover ; inline
] 2curry each
] keep ;
+: check-about ( vocab -- )
+ [ vocab-help [ article drop ] when* ] check-something ;
+
: check-vocab ( vocab -- seq )
"Checking " write dup write "..." print
[
- dup words [ check-word ] each
- "vocab-articles" get at [ check-article ] each
+ [ check-about ]
+ [ words [ check-word ] each ]
+ [ "vocab-articles" get at [ check-article ] each ]
+ tri
] { } make ;
: run-help-lint ( prefix -- alist )
! 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
-USING: kernel words inspector slots quotations sequences assocs
-math arrays inference effects shuffle continuations debugger
-classes.tuple namespaces vectors bit-arrays byte-arrays strings
-sbufs math.functions macros sequences.private combinators
-mirrors combinators.lib combinators.short-circuit ;
+! Copyright (C) 2007, 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel words inspector slots quotations
+sequences assocs math arrays inference effects shuffle
+continuations debugger classes.tuple namespaces vectors
+bit-arrays byte-arrays strings sbufs math.functions macros
+sequences.private combinators mirrors combinators.lib
+combinators.short-circuit ;
IN: inverse
TUPLE: fail ;
] } 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 } = ;
[ ] like [ drop ] compose ;
: ?wrapped ( object -- wrapped )
- dup wrapper? [ wrapped ] when ;
+ dup wrapper? [ wrapped>> ] when ;
: boa-inverse ( class -- quot )
[ deconstruct-pred ] keep slot-readers compose ;
IN: io.buffers
ARTICLE: "buffers" "Locked I/O buffers"
-"I/O buffers are first-in-first-out queues of bytes. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends."
+"I/O buffers are first-in-first-out queues of bytes."
+$nl
+"Buffers are backed by manually allocated storage that does not get moved by the garbage collector; they are also low-level and sacrifice error checking for efficiency."
+$nl
+"Buffers are used to implement native I/O backends."
$nl
"Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
{ $subsection buffer }
{ $subsection buffer-pop }
{ $subsection buffer-read }
"Writing to the buffer:"
-{ $subsection extend-buffer }
{ $subsection byte>buffer }
{ $subsection >buffer }
{ $subsection n>buffer } ;
{ $values { "buffer" buffer } { "?" "a boolean" } }
{ $description "Tests if the buffer contains no more data to be read." } ;
-HELP: extend-buffer
-{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
-{ $description "Grows a buffer to fit " { $snippet "n" } " bytes of data." } ;
-
-HELP: check-overflow
-{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
-{ $description "Grows the buffer, if possible, so it can accomodate " { $snippet "n" } " bytes." }
-{ $warning "I/O system implementations should call this word or one of the other words that calls this word, at the beginning of an I/O transaction, when the buffer is empty. Buffers cannot be resized if they contain data; one of the requirements of a buffer is to remain fixed in memory while I/O operations are in progress." }
-{ $errors "Throws an error if the buffer contains unread data, and the new data does not fit." } ;
-
HELP: >buffer
{ $values { "byte-array" byte-array } { "buffer" buffer } }
-{ $description "Copies a byte array to the buffer's fill pointer, and advances it accordingly." } ;
+{ $description "Copies a byte array to the buffer's fill pointer, and advances it accordingly." }
+{ $warning "This word will corrupt memory if the byte array is larger than the space available in the buffer." } ;
HELP: byte>buffer
{ $values { "byte" "a byte" } { "buffer" buffer } }
-{ $description "Appends a single byte to a buffer." } ;
+{ $description "Appends a single byte to a buffer." }
+{ $warning "This word will corrupt memory if the buffer is full." } ;
HELP: n>buffer
{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
{ $description "Advances the fill pointer by " { $snippet "n" } " bytes." }
-{ $errors "Throws an error if the buffer does not contain " { $snippet "n" } " bytes of data." } ;
+{ $warning "This word will leave the buffer in an invalid state if it does not have " { $snippet "n" } " bytes available." } ;
HELP: buffer-peek
{ $values { "buffer" buffer } { "byte" "a byte" } }
hints accessors math.order destructors combinators ;
IN: io.buffers
-TUPLE: buffer size ptr fill pos disposed ;
+TUPLE: buffer
+{ size fixnum }
+{ ptr simple-alien initial: ALIEN: -1 }
+{ fill fixnum }
+{ pos fixnum }
+disposed ;
: <buffer> ( n -- buffer )
dup malloc 0 0 f buffer boa ;
HINTS: buffer-read fixnum buffer ;
-: extend-buffer ( n buffer -- )
- 2dup ptr>> swap realloc >>ptr swap >>size drop ;
- inline
-
-: check-overflow ( n buffer -- )
- 2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
- inline
-
: buffer-end ( buffer -- alien )
[ fill>> ] [ ptr>> ] bi <displaced-alien> ; inline
: n>buffer ( n buffer -- )
- [ + ] change-fill
- [ fill>> ] [ size>> ] bi >
- [ "Buffer overflow" throw ] when ; inline
+ [ + ] change-fill drop ; inline
+
+HINTS: n>buffer fixnum buffer ;
: >buffer ( byte-array buffer -- )
- [ [ length ] dip check-overflow ]
[ buffer-end byte-array>memory ]
[ [ length ] dip n>buffer ]
- 2tri ;
+ 2bi ;
HINTS: >buffer byte-array buffer ;
: byte>buffer ( byte buffer -- )
- [ 1 swap check-overflow ]
[ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
[ 1 swap n>buffer ]
- tri ;
+ bi ;
HINTS: byte>buffer fixnum buffer ;
M: output-port stream-write
dup check-disposed
over length over buffer>> buffer-size > [
- [ buffer>> buffer-size <groups> ]
+ [ buffer>> size>> <groups> ]
[ [ stream-write ] curry ] bi
each
] [
"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
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs hashtables assocs io kernel math
+USING: accessors arrays assocs hashtables assocs io kernel math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
splitting sorting shuffle symbols sets math.order ;
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 ;
"lambda" word-prop body>> ;
M: lambda-word reset-word
- [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-macro macro lambda-word ;
: 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" } }
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: parser-combinators memoize kernel sequences\r
+USING: accessors parser-combinators memoize kernel sequences\r
logging arrays words strings vectors io io.files\r
namespaces combinators combinators.lib logging.server\r
calendar calendar.format ;\r
\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
M: macro definition "macro" word-prop ;
M: macro reset-word
- [ f "macro" set-word-prop ] [ call-next-method ] bi ;
+ [ call-next-method ] [ f "macro" set-word-prop ] bi ;
: macro-expand ( ... word -- quot ) "macro" word-prop call ;
-! 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 )
sequences.private accessors ;
IN: math.ranges
-TUPLE: range from length step ;
+TUPLE: range
+{ from read-only }
+{ length read-only }
+{ step read-only } ;
: <range> ( a b step -- range )
>r over - r>
: ,b) dup neg rot + swap ; inline
-: [a,b] ( a b -- range ) twiddle <range> ;
+: [a,b] ( a b -- range ) twiddle <range> ; foldable
-: (a,b] ( a b -- range ) twiddle (a, <range> ;
+: (a,b] ( a b -- range ) twiddle (a, <range> ; foldable
-: [a,b) ( a b -- range ) twiddle ,b) <range> ;
+: [a,b) ( a b -- range ) twiddle ,b) <range> ; foldable
-: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ;
+: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ; foldable
-: [0,b] ( b -- range ) 0 swap [a,b] ;
+: [0,b] ( b -- range ) 0 swap [a,b] ; foldable
-: [1,b] ( b -- range ) 1 swap [a,b] ;
+: [1,b] ( b -- range ) 1 swap [a,b] ; foldable
-: [0,b) ( b -- range ) 0 swap [a,b) ;
+: [0,b) ( b -- range ) 0 swap [a,b) ; foldable
: range-increasing? ( range -- ? )
step>> 0 > ;
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 > ;
M: memoized definition "memo-quot" word-prop ;
M: memoized reset-word
- [ { "memoize" "memo-quot" } reset-props ]
[ call-next-method ]
+ [ { "memoize" "memo-quot" } reset-props ]
bi ;
: memoize-quot ( quot effect -- memo-quot )
"forgotten" word-prop not ;
: method-word-name ( specializer generic -- string )
- [ word-name % "-" % unparse % ] "" make ;
+ [ name>> % "-" % unparse % ] "" make ;
: method-word-props ( specializer generic -- assoc )
[
: <method> ( specializer generic -- word )
[ method-word-props ] 2keep
method-word-name f <word>
- [ set-word-props ] keep ;
+ swap >>props ;
: with-methods ( word quot -- )
over >r >r "multi-methods" word-prop
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien alien.strings alien.syntax combinators
-alien.c-types strings sequences namespaces words math threads
-io.encodings.ascii ;
+USING: accessors kernel alien alien.strings alien.syntax
+combinators alien.c-types strings sequences namespaces words
+math threads io.encodings.ascii ;
IN: odbc
<< "odbc" "odbc32.dll" "stdcall" add-library >>
{ 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 ;
TUPLE: demo-gadget yaw pitch distance ;
: <demo-gadget> ( yaw pitch distance -- gadget )
- demo-gadget construct-gadget
- [ { (>>yaw) (>>pitch) (>>distance) } set-slots ] keep ;
+ demo-gadget construct-gadget
+ swap >>distance
+ swap >>pitch
+ swap >>yaw ;
GENERIC: far-plane ( gadget -- z )
GENERIC: near-plane ( gadget -- z )
[
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 -- )
[
+++ /dev/null
-USING: assocs words sequences arrays compiler tools.time\r
-io.styles io prettyprint vocabs kernel sorting generator\r
-optimizer math math.order ;\r
-IN: optimizer.report\r
-\r
-: count-optimization-passes ( nodes n -- n )\r
- >r optimize-1\r
- [ r> 1+ count-optimization-passes ] [ drop r> ] if ;\r
-\r
-: results ( seq -- )\r
- [ [ second ] prepose compare ] curry sort 20 tail*\r
- print\r
- standard-table-style\r
- [\r
- [ [ [ pprint-cell ] each ] with-row ] each\r
- ] tabular-output ;\r
-\r
-: optimizer-report ( -- )\r
- all-words [ compiled? ] filter\r
- [\r
- dup [\r
- word-dataflow nip 1 count-optimization-passes\r
- ] benchmark 2array\r
- ] { } map>assoc\r
- [ first ] "Worst number of optimizer passes:" results\r
- [ second ] "Worst compile times:" results ;\r
-\r
-MAIN: optimizer-report\r
FT_PIXEL_MODE_GRAY
"FT_Bitmap" <c-object> dup >r
{
- set-FT_Bitmap-rows
- set-FT_Bitmap-width
- set-FT_Bitmap-pitch
- set-FT_Bitmap-buffer
- set-FT_Bitmap-num_grays
- set-FT_Bitmap-pixel_mode
- } set-slots r> ;
+ [ set-FT_Bitmap-pixel_mode ]
+ [ set-FT_Bitmap-num_grays ]
+ [ set-FT_Bitmap-buffer ]
+ [ set-FT_Bitmap-pitch ]
+ [ set-FT_Bitmap-width ]
+ [ set-FT_Bitmap-rows ]
+ } cleave r> ;
: render-layout ( layout -- dims alien )
[
-USING: math math.parser calendar calendar.format strings words
-kernel effects ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math math.parser calendar calendar.format
+strings words kernel effects ;
IN: present
GENERIC: present ( object -- string )
M: string present ;
-M: word present word-name ;
+M: word present name>> ;
M: effect present effect>string ;
-USING: assocs math kernel shuffle combinators.lib\r
+USING: accessors assocs math kernel shuffle combinators.lib\r
words quotations arrays combinators sequences math.vectors\r
io.styles prettyprint vocabs sorting io generic locals.private\r
math.statistics math.order ;\r
\r
M: word noise badness 1 2array ;\r
\r
-M: wrapper noise wrapped noise ;\r
+M: wrapper noise wrapped>> noise ;\r
\r
M: let noise let-body noise ;\r
\r
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
-USING: assocs words sequences arrays compiler tools.time\r
-io.styles io prettyprint vocabs kernel sorting generator\r
-optimizer math math.order ;\r
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors assocs words sequences arrays compiler\r
+tools.time io.styles io prettyprint vocabs kernel sorting\r
+generator optimizer math math.order ;\r
IN: report.optimizer\r
\r
: count-optimization-passes ( nodes n -- n )\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 ;
M: wrapper (serialize) ( obj -- )
CHAR: W write1
- wrapped (serialize) ;
+ wrapped>> (serialize) ;
DEFER: (deserialize) ( -- obj )
gensym {
[ intern-object ]
[ (deserialize) define ]
- [ (deserialize) swap set-word-props ]
+ [ (deserialize) >>props drop ]
[ ]
} cleave ;
! 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. ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: qualified io.streams.c init fry namespaces assocs kernel
-parser lexer strings.parser tools.deploy.config vocabs sequences
-words words.private memory kernel.private continuations io
-prettyprint vocabs.loader debugger system strings sets ;
+USING: accessors qualified io.streams.c init fry namespaces
+assocs kernel parser lexer strings.parser tools.deploy.config
+vocabs sequences words words.private memory kernel.private
+continuations io prettyprint vocabs.loader debugger system
+strings sets ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
: strip-word-names ( words -- )
"Stripping word names" show
- [ f over set-word-name f swap set-word-vocabulary ] each ;
+ [ f >>name f >>vocabulary drop ] each ;
: strip-word-defs ( words -- )
"Stripping symbolic word definitions" show
[ "no-def-strip" word-prop not ] filter
- [ [ ] swap set-word-def ] each ;
+ [ [ ] >>def drop ] each ;
: strip-word-props ( stripped-props words -- )
"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
+ ] keep (>>props)
] with each ;
: stripped-word-props ( -- seq )
IN: tools.profiler.tests
-USING: tools.profiler tools.test kernel memory math threads
-alien tools.profiler.private sequences ;
+USING: accessors tools.profiler tools.test kernel memory math
+threads alien tools.profiler.private sequences ;
[ t ] [
- \ length profile-counter
+ \ length counter>>
10 [ { } length drop ] times
- \ length profile-counter =
+ \ length counter>> =
] unit-test
[ ] [ [ 10 [ gc ] times ] profile ] unit-test
foobar
] profile
-[ 1 ] [ \ foobar profile-counter ] unit-test
+[ 1 ] [ \ foobar counter>> ] unit-test
: fooblah { } [ ] each ;
[ foobaz ] profile
-[ 1 ] [ \ foobaz profile-counter ] unit-test
+[ 1 ] [ \ foobaz counter>> ] unit-test
-[ 2 ] [ \ fooblah profile-counter ] unit-test
+[ 2 ] [ \ fooblah counter>> ] unit-test
-! 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
-USING: kernel sequences slots parser lexer words classes
-slots.private mirrors ;
+USING: classes.tuple accessors kernel sequences slots parser
+lexer words classes slots.private mirrors ;
IN: tuple-syntax
! TUPLE: foo bar baz ;
: parse-slot-writer ( tuple -- slot# )
scan dup "}" = [ 2drop f ] [
- but-last swap object-slots slot-named slot-spec-offset
+ but-last swap class all-slots slot-named offset>>
] if ;
: parse-slots ( accum tuple -- accum tuple )
! 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
! Thanks to Mackenzie Straight for the idea
-USING: kernel parser lexer words namespaces sequences quotations ;
+USING: accessors kernel parser lexer words namespaces sequences quotations ;
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
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces sequences words io assocs
+USING: accessors kernel namespaces sequences words io assocs
quotations strings parser lexer arrays xml.data xml.writer debugger
splitting vectors sequences.deep combinators ;
IN: xml.utilities
"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*
-USING: xmode.tokens xmode.keyword-map kernel
+USING: accessors xmode.tokens xmode.keyword-map kernel
sequences vectors assocs strings memoize regexp unicode.case ;
IN: xmode.rules
finalized?
;
-: init-rule-set ( ruleset -- )
- #! Call after constructor.
- >r H{ } clone H{ } clone V{ } clone r>
- {
- set-rule-set-rules
- set-rule-set-props
- set-rule-set-imports
- } set-slots ;
-
: <rule-set> ( -- ruleset )
- rule-set new dup init-rule-set ;
+ rule-set new
+ H{ } clone >>rules
+ H{ } clone >>props
+ V{ } clone >>imports ;
MEMO: standard-rule-set ( id -- ruleset )
<rule-set> [ set-rule-set-default ] keep ;
-USING: parser words sequences namespaces kernel assocs
+USING: accessors parser words sequences namespaces kernel assocs
compiler.units ;
IN: xmode.tokens
{ "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