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

Builtinn types now use new slot accessors; tuple slot type declaration work in progress

db4
Slava Pestov 2008-06-28 02:36:20 -05:00
parent 0b86e87544
commit b36e06d0d6
138 changed files with 801 additions and 724 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/alien-docs.factor
View File

@ -10,7 +10,7 @@ HELP: alien
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

12
core/alien/alien.factor
View File

@ -1,13 +1,12 @@
! 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 ;
@ -17,12 +16,15 @@ 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 )

5
core/alien/c-types/c-types.factor
View File

@ -242,11 +242,10 @@ M: long-long-type box-return ( type -- )
} 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 )

6
core/alien/remote-control/remote-control.factor
View File

@ -1,7 +1,7 @@
! 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 )
@ -15,7 +15,7 @@ IN: alien.remote-control
"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

2
core/alien/strings/strings.factor
View File

@ -100,7 +100,7 @@ M: utf16n <encoder> drop utf16n <encoder> ;
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 ]

8
core/alien/structs/structs-docs.factor
View File

@ -7,7 +7,7 @@ kernel words slots assocs namespaces ;
: ($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 -- )
@ -22,6 +22,9 @@ kernel words slots assocs namespaces ;
" 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 [
@ -49,6 +52,9 @@ M: word slot-specs "slots" word-prop ;
" 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 [

28
core/alien/structs/structs.factor
View File

@ -1,7 +1,7 @@
! 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
@ -10,9 +10,9 @@ 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 -- )
@ -23,7 +23,7 @@ IN: alien.structs
[ ]
[ slot-spec-reader ]
[
slot-spec-type
class>>
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ;
@ -32,7 +32,7 @@ IN: alien.structs
[ 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 -- )
@ -77,13 +77,13 @@ M: struct-type stack-size
-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 ;
@ -94,7 +94,7 @@ M: struct-type stack-size
: 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 ;

19
core/bootstrap/compiler/compiler.factor
View File

@ -1,11 +1,12 @@
! 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
@ -14,12 +15,12 @@ IN: bootstrap.compiler
"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
@ -40,8 +41,6 @@ nl
wrap probe
underlying
namestack*
bitand bitor bitxor bitnot

34
core/bootstrap/image/image.factor
View File

@ -12,8 +12,8 @@ io.encodings.binary math.order accessors ;
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 ;
@ -260,10 +260,10 @@ M: f '
[
{
[ hashcode , ]
[ word-name , ]
[ word-vocabulary , ]
[ word-def , ]
[ word-props , ]
[ name>> , ]
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
} cleave
f ,
0 , ! count
@ -277,7 +277,7 @@ M: f '
] 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 ;
@ -294,7 +294,7 @@ M: word ' ;
! Wrappers
M: wrapper '
wrapped ' wrapper type-number object tag-number
wrapped>> ' wrapper type-number object tag-number
[ emit ] emit-object ;
! Strings
@ -345,7 +345,7 @@ M: float-array ' float-array emit-dummy-array ;
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 ;
@ -354,11 +354,11 @@ M: tuple-layout '
[
[
{
[ layout-hashcode , ]
[ layout-class , ]
[ layout-size , ]
[ layout-superclasses , ]
[ layout-echelon , ]
[ hashcode>> , ]
[ class>> , ]
[ size>> , ]
[ superclasses>> , ]
[ echelon>> , ]
} cleave
] { } make [ ' ] map
\ tuple-layout type-number
@ -368,7 +368,7 @@ M: tuple-layout '
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
word-def first [ emit-tuple ] cache-object ;
def>> first [ emit-tuple ] cache-object ;
! Arrays
M: array '
@ -379,10 +379,10 @@ 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

262
core/bootstrap/primitives.factor
View File

@ -5,7 +5,7 @@ hashtables.private io kernel math 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
slots classes.union classes.intersection
compiler.units bootstrap.image.private io.files accessors
combinators ;
IN: bootstrap.primitives
@ -133,9 +133,12 @@ bootstrapping? on
[ f f f builtin-class define-class ]
tri ;
: define-builtin-slots ( symbol slotspec -- )
[ drop ] [ 1 simple-slots ] 2bi
[ "slots" set-word-prop ] [ define-slots ] 2bi ;
: prepare-slots ( slots -- slots' )
[ [ dup array? [ first2 create ] when ] map ] map ;
: define-builtin-slots ( class slots -- )
prepare-slots 1 make-slots
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin ( symbol slotspec -- )
>r [ define-builtin-predicate ] keep
@ -189,16 +192,14 @@ bi
"ratio" "math" create {
{
{ "integer" "math" }
"numerator"
{ "numerator" "math" }
f
{ "integer" "math" }
read-only: t
}
{
{ "integer" "math" }
"denominator"
{ "denominator" "math" }
f
{ "integer" "math" }
read-only: t
}
} define-builtin
@ -207,16 +208,14 @@ bi
"complex" "math" create {
{
"real"
{ "real" "math" }
"real-part"
{ "real-part" "math" }
f
read-only: t
}
{
"imaginary"
{ "real" "math" }
"imaginary-part"
{ "imaginary-part" "math" }
f
read-only: t
}
} define-builtin
@ -226,104 +225,87 @@ bi
"wrapper" "kernel" create {
{
{ "object" "kernel" }
"wrapped"
{ "wrapped" "kernel" }
f
{ "object" "kernel" }
read-only: t
}
} define-builtin
"string" "strings" create {
{
{ "array-capacity" "sequences.private" }
"length"
{ "length" "sequences" }
f
{ "array-capacity" "sequences.private" }
read-only: t
} {
{ "object" "kernel" }
"aux"
{ "string-aux" "strings.private" }
{ "set-string-aux" "strings.private" }
{ "object" "kernel" }
}
} define-builtin
"quotation" "quotations" create {
{
{ "object" "kernel" }
"array"
{ "quotation-array" "quotations.private" }
f
{ "object" "kernel" }
read-only: t
}
{
"compiled"
{ "object" "kernel" }
"compiled?"
{ "quotation-compiled?" "quotations" }
f
read-only: t
}
} define-builtin
"dll" "alien" create {
{
{ "byte-array" "byte-arrays" }
"path"
{ "(dll-path)" "alien" }
f
{ "byte-array" "byte-arrays" }
read-only: t
}
}
define-builtin
"alien" "alien" create {
{
"underlying"
{ "c-ptr" "alien" }
"alien"
{ "underlying-alien" "alien" }
f
read-only: t
} {
{ "object" "kernel" }
"expired?"
{ "expired?" "alien" }
f
{ "object" "kernel" }
read-only: t
}
}
define-builtin
"word" "words" create {
f
{
{ "object" "kernel" }
"name"
{ "word-name" "words" }
{ "set-word-name" "words" }
}
{
{ "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
}
{
"hashcode"
{ "fixnum" "math" }
}
{
"name"
{ "object" "kernel" }
}
{
"vocabulary"
{ "object" "kernel" }
}
{
"def"
{ "quotation" "quotations" }
}
{
"props"
{ "object" "kernel" }
}
{
"compiled"
{ "object" "kernel" }
read-only: t
}
{
"counter"
{ "profile-counter" "tools.profiler.private" }
{ "set-profile-counter" "tools.profiler.private" }
{ "fixnum" "math" }
}
} define-builtin
@ -337,34 +319,29 @@ define-builtin
"tuple-layout" "classes.tuple.private" create {
{
{ "fixnum" "math" }
"hashcode"
{ "layout-hashcode" "classes.tuple.private" }
f
{ "fixnum" "math" }
read-only: t
}
{
{ "word" "words" }
"class"
{ "layout-class" "classes.tuple.private" }
f
{ "word" "words" }
read-only: t
}
{
{ "fixnum" "math" }
"size"
{ "layout-size" "classes.tuple.private" }
f
}
{
{ "array" "arrays" }
"superclasses"
{ "layout-superclasses" "classes.tuple.private" }
f
}
{
{ "fixnum" "math" }
read-only: t
}
{
"superclasses"
{ "array" "arrays" }
read-only: t
}
{
"echelon"
{ "layout-echelon" "classes.tuple.private" }
f
{ "fixnum" "math" }
read-only: t
}
} define-builtin
@ -375,15 +352,13 @@ define-builtin
[
{
{
{ "object" "kernel" }
"delegate"
{ "delegate" "kernel" }
{ "set-delegate" "kernel" }
}
{ "object" "kernel" }
}
} prepare-slots
[ drop ] [ generate-tuple-slots ] 2bi
[ "slots" set-word-prop ]
[ define-slots ]
[ define-accessors ]
2bi
]
} cleave
@ -405,90 +380,19 @@ 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" }
read-only: t
} {
"quot"
{ "curry-quot" "kernel" }
f
{ "object" "kernel" }
read-only: t
}
} define-tuple-class
} prepare-slots define-tuple-class
"curry" "kernel" lookup
[ f "inline" set-word-prop ]
@ -500,17 +404,15 @@ tuple
tuple
{
{
{ "object" "kernel" }
"first"
{ "compose-first" "kernel" }
f
} {
{ "object" "kernel" }
read-only: t
} {
"second"
{ "compose-second" "kernel" }
f
{ "object" "kernel" }
read-only: t
}
} define-tuple-class
} prepare-slots define-tuple-class
"compose" "kernel" lookup
[ f "inline" set-word-prop ]

4
core/bootstrap/stage2.factor
View File

@ -1,6 +1,6 @@
! 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
@ -36,7 +36,7 @@ SYMBOL: bootstrap-time
"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

3
core/bootstrap/syntax.factor
View File

@ -45,6 +45,7 @@ IN: bootstrap.syntax
"SINGLETON:"
"SYMBOL:"
"TUPLE:"
"SLOT:"
"T{"
"UNION:"
"INTERSECTION:"
@ -68,6 +69,8 @@ IN: bootstrap.syntax
"<<"
">>"
"call-next-method"
"initial:"
"read-only:"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol

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

@ -4,6 +4,10 @@ USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays ;
IN: byte-vectors
TUPLE: byte-vector
{ "underlying" byte-array }
{ "length" array-capacity } ;
<PRIVATE
: byte-array>vector ( byte-array length -- byte-vector )

2
core/classes/algebra/algebra.factor
View File

@ -214,7 +214,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
[ "Topological sort failed" throw ] unless* ;
: sort-classes ( seq -- newseq )
[ [ word-name ] compare ] sort >vector
[ [ name>> ] compare ] sort >vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;

8
core/classes/classes.factor
View File

@ -1,6 +1,6 @@
! 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
@ -38,7 +38,7 @@ PREDICATE: tuple-class < class
: 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 ;
@ -123,8 +123,8 @@ M: sequence implementors [ implementors ] gather ;
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 ]

59
core/classes/tuple/parser/parser-tests.factor Normal file
View File

@ -0,0 +1,59 @@
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units ;
TUPLE: test-1 ;
[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test
TUPLE: test-2 < test-1 ;
[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test
[ test-1 ] [ test-2 superclass ] unit-test
TUPLE: test-3 a ;
[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test
[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
TUPLE: test-4 < test-3 b ;
[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test
TUPLE: test-5 { "a" integer } ;
[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test
TUPLE: test-6 < test-5 { "b" integer } ;
[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test
[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test
TUPLE: test-7 { "b" integer initial: 3 } ;
[ 3 ] [ "b" test-7 "slots" word-prop slot-named initial>> ] unit-test
TUPLE: test-8 { "b" integer read-only: t } ;
[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
[ error>> invalid-slot-name? ]
must-fail-with
[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ]
[ error>> invalid-slot-name? ]
must-fail-with
[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ]
[ error>> unexpected-eof? ]
must-fail-with
[ ] [
[
{ test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 }
[ dup class? [ forget-class ] [ drop ] if ] each
] with-compilation-unit
] unit-test

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

@ -1,7 +1,7 @@
! 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 )
@ -13,7 +13,7 @@ IN: classes.tuple.parser
"Definition of slot ``" %
%
"'' in class ``" %
word-name %
name>> %
"'' shadows a superclass slot" %
] "" make note.
] with each ;
@ -24,27 +24,27 @@ M: invalid-slot-name summary
drop
"Invalid slot name" ;
: (parse-tuple-slots) ( -- )
: parse-slot-name ( string/f -- ? )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
#! TUPLE: blahblah foo bing
#!
#! : ...
scan {
{
{ [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop ] }
[ , (parse-tuple-slots) ]
{ [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop f ] }
[ dup "{" = [ drop \ } parse-until >array ] when , t ]
} cond ;
: parse-tuple-slots ( -- seq )
[ (parse-tuple-slots) ] { } make ;
: parse-tuple-slots ( -- )
scan parse-slot-name [ parse-tuple-slots ] when ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word parse-tuple-slots ] }
[ >r tuple parse-tuple-slots r> prefix ]
{ "<" [ scan-word [ parse-tuple-slots ] { } make ] }
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
} case 3dup check-slot-shadowing ;

33
core/classes/tuple/tuple-docs.factor
View File

@ -1,6 +1,7 @@
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"
@ -242,6 +243,34 @@ $nl
}
"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" }
@ -255,6 +284,8 @@ $nl
{ $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:"

8
core/classes/tuple/tuple-tests.factor
View File

@ -88,13 +88,13 @@ C: <empty> empty
[ 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>
@ -253,8 +253,8 @@ test-laptop-slot-values
[ laptop ] [
"laptop" get 1 slot
dup layout-echelon swap
layout-superclasses nth
dup echelon>> swap
superclasses>> nth
] unit-test
[ "TUPLE: laptop < computer battery ;" ] [

15
core/classes/tuple/tuple.factor
View File

@ -25,7 +25,7 @@ ERROR: not-a-tuple-class class ;
check-tuple-class "layout" word-prop ;
: tuple-size ( tuple -- size )
1 slot layout-size ; inline
1 slot size>> ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ;
@ -38,7 +38,7 @@ PRIVATE>
: 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 ;
@ -78,10 +78,10 @@ ERROR: bad-superclass class ;
#! 5 slot == layout-echelon
[
[ 1 slot dup 5 slot ] %
dup tuple-layout layout-echelon ,
dup tuple-layout echelon>> ,
[ fixnum>= ] %
[
dup tuple-layout layout-echelon ,
dup tuple-layout echelon>> ,
[ swap 4 slot array-nth ] %
literalize ,
[ eq? ] %
@ -106,7 +106,7 @@ ERROR: bad-superclass class ;
[ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs )
over superclass-size 2 + simple-slots ;
over superclass-size 2 + make-slots deprecated-slots ;
: define-tuple-slots ( class -- )
dup dup "slot-names" word-prop generate-tuple-slots
@ -212,13 +212,14 @@ M: tuple-class define-tuple-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 ]
[ { "layout" "slots" "slot-names" } reset-props ]
bi
] bi ;

6
core/combinators/combinators-tests.factor
View File

@ -140,7 +140,7 @@ IN: combinators.tests
[ "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
@ -158,7 +158,7 @@ IN: combinators.tests
[ 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' )
{
@ -288,7 +288,7 @@ IN: combinators.tests
] unit-test
! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
[ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test
[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test

4
core/combinators/combinators.factor
View File

@ -1,6 +1,6 @@
! 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
@ -45,7 +45,7 @@ ERROR: no-case ;
dupd first dup word? [
execute
] [
dup wrapper? [ wrapped ] when
dup wrapper? [ wrapped>> ] when
] if =
] [ quotation? ] if
] find nip ;

2
core/compiler/tests/intrinsics.factor
View File

@ -377,7 +377,7 @@ cell 8 = [
[ 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

28
core/compiler/tests/redefine1.factor
View File

@ -23,13 +23,13 @@ M: integer method-redefine-test 3 + ;
: 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
@ -44,24 +44,24 @@ 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

4
core/compiler/tests/redefine3.factor
View File

@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
: 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
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
[ ] [ [ 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

2
core/compiler/tests/simple.factor
View File

@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
"USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
] unit-test
] times

4
core/compiler/tests/templates.factor
View File

@ -245,13 +245,13 @@ TUPLE: my-tuple ;
[ 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

6
core/compiler/units/units.factor
View File

@ -1,7 +1,7 @@
! 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
@ -54,7 +54,7 @@ GENERIC: definitions-changed ( assoc obj -- )
: 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

2
core/continuations/continuations-tests.factor
View File

@ -66,7 +66,7 @@ IN: continuations.tests
[ 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

4
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -438,13 +438,13 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
\ <tuple> [
tuple "layout" get layout-size 2 + cells %allot
tuple "layout" get size>> 2 + cells %allot
! Store layout
"layout" get 12 load-indirect
12 11 cell STW
! Zero out the rest of the tuple
f v>operand 12 LI
"layout" get layout-size [ 12 11 rot 2 + cells STW ] each
"layout" get size>> [ 12 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] H{

2
core/cpu/x86/64/64.factor
View File

@ -178,7 +178,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: 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 )

6
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -1,6 +1,6 @@
! 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
@ -290,12 +290,12 @@ IN: cpu.x86.intrinsics
} define-intrinsic
\ <tuple> [
tuple "layout" get layout-size 2 + cells [
tuple "layout" get size>> 2 + cells [
! Store layout
"layout" get "scratch" get load-literal
1 object@ "scratch" operand MOV
! Zero out the rest of the tuple
"layout" get layout-size [
"layout" get size>> [
2 + object@ f v>operand MOV
] each
! Store tagged ptr in reg

4
core/effects/effects.factor
View File

@ -24,7 +24,7 @@ TUPLE: effect in out terminated? ;
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 )
@ -46,7 +46,7 @@ M: symbol stack-effect drop (( -- symbol )) ;
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> ;

4
core/generator/fixup/fixup.factor
View File

@ -88,7 +88,7 @@ TUPLE: rel-fixup arg class type ;
: 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*
@ -120,7 +120,7 @@ SYMBOL: literal-table
>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 ;

4
core/generator/generator.factor
View File

@ -1,6 +1,6 @@
! 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
@ -20,7 +20,7 @@ SYMBOL: compiled
} cond ;
: maybe-compile ( word -- )
dup compiled? [ drop ] [ queue-compile ] if ;
dup compiled>> [ drop ] [ queue-compile ] if ;
SYMBOL: compiling-word

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

@ -144,7 +144,7 @@ M: integer generic-forget-test-1 / ;
[ t ] [
\ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
[ name>> "generic-forget-test-1/integer" = ] contains?
] unit-test
[ ] [
@ -153,7 +153,7 @@ M: integer generic-forget-test-1 / ;
[ f ] [
\ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
[ name>> "generic-forget-test-1/integer" = ] contains?
] unit-test
GENERIC: generic-forget-test-2 ( a b -- c )
@ -162,7 +162,7 @@ M: sequence generic-forget-test-2 = ;
[ t ] [
\ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
[ name>> "generic-forget-test-2/sequence" = ] contains?
] unit-test
[ ] [
@ -171,7 +171,7 @@ M: sequence generic-forget-test-2 = ;
[ f ] [
\ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
[ name>> "generic-forget-test-2/sequence" = ] contains?
] unit-test
GENERIC: generic-forget-test-3 ( a -- b )

8
core/generic/generic.factor
View File

@ -1,7 +1,7 @@
! 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
@ -72,7 +72,7 @@ TUPLE: check-method class generic ;
3tri ; inline
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
[ name>> ] bi@ "=>" swap 3append ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
@ -93,7 +93,7 @@ M: method-body crossref?
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

4
core/generic/standard/engines/tuple/tuple.factor
View File

@ -18,7 +18,7 @@ C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
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' )
@ -54,7 +54,7 @@ M: trivial-tuple-dispatch-engine engine>quot
] [ ] 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? ;

2
core/generic/standard/standard-tests.factor
View File

@ -287,7 +287,7 @@ M: sbuf no-stack-effect-decl ;
[ ] [ \ 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 ;

26
core/growable/growable-docs.factor
View File

@ -7,31 +7,17 @@ ARTICLE: "growable" "Resizable sequence implementation"
$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." } ;

27
core/growable/growable.factor
View File

@ -1,24 +1,24 @@
! 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
@ -35,7 +35,7 @@ M: growable set-length ( n seq -- )
] [
2dup capacity > [ 2dup expand ] when
] if
>r >fixnum r> set-fill ;
swap >fixnum >>length drop ;
: new-size ( old -- new ) 1+ 3 * ; inline
@ -44,20 +44,19 @@ M: growable set-length ( n seq -- )
2dup length >= [
2dup capacity >= [ over new-size over expand ] when
>r >fixnum r>
2dup >r 1 fixnum+fast r> set-fill
2dup swap 1 fixnum+fast >>length drop
] [
>r >fixnum r>
] if ; inline
M: growable set-nth ensure set-nth-unsafe ;
M: growable clone ( seq -- newseq )
(clone) dup underlying clone over set-underlying ;
M: growable clone (clone) [ clone ] change-underlying ;
M: growable lengthen ( n seq -- )
2dup length > [
2dup capacity > [ over new-size over expand ] when
2dup >r >fixnum r> set-fill
2dup swap >fixnum >>length drop
] when 2drop ;
INSTANCE: growable sequence

2
core/hashtables/hashtables-docs.factor
View File

@ -8,7 +8,7 @@ ARTICLE: "hashtables.private" "Hashtable implementation details"
$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:"

43
core/hashtables/hashtables.factor
View File

@ -1,9 +1,14 @@
! 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 )
@ -23,16 +28,16 @@ IN: hashtables
] 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? [
@ -46,17 +51,17 @@ IN: hashtables
] 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@
@ -67,11 +72,11 @@ IN: hashtables
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
@ -98,7 +103,7 @@ M: hashtable at* ( key hash -- value ? )
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@ [
@ -109,14 +114,12 @@ M: hashtable delete-at ( key hash -- )
] 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 ;
@ -125,10 +128,10 @@ M: hashtable set-at ( value key hash -- )
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? [

8
core/inference/backend/backend.factor
View File

@ -111,7 +111,7 @@ GENERIC: apply-object ( obj -- )
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, ;
@ -400,7 +400,7 @@ TUPLE: missing-effect word ;
{ [ 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 -- )
@ -429,7 +429,7 @@ TUPLE: 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
@ -492,7 +492,7 @@ M: #return collect-label-info*
: 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

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

@ -159,7 +159,7 @@ DEFER: blah
[ 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 )

2
core/inference/inference-tests.factor
View File

@ -271,7 +271,7 @@ DEFER: #1
: #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

4
core/inference/known-words/known-words.factor
View File

@ -1,6 +1,6 @@
! 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
@ -137,7 +137,7 @@ M: object infer-call
! 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

6
core/inference/transforms/transforms-tests.factor
View File

@ -31,19 +31,19 @@ C: <color> color
[ 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

8
core/inspector/inspector.factor
View File

@ -1,6 +1,6 @@
! 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 ;
@ -9,7 +9,7 @@ IN: inspector
GENERIC: summary ( object -- string )
: object-summary ( object -- string )
class word-name " instance" append ;
class name>> " instance" append ;
M: object summary object-summary ;
@ -24,7 +24,7 @@ M: word summary synopsis ;
M: sequence summary
[
dup class word-name %
dup class name>> %
" with " %
length #
" elements" %
@ -32,7 +32,7 @@ M: sequence summary
M: assoc summary
[
dup class word-name %
dup class name>> %
" with " %
assoc-size #
" entries" %

10
core/io/streams/string/string.factor
View File

@ -1,8 +1,8 @@
! 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 ;
@ -21,7 +21,7 @@ M: growable stream-flush 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 ;

2
core/io/styles/styles-docs.factor
View File

@ -94,7 +94,7 @@ HELP: font-style
{ $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

8
core/kernel/kernel.factor
View File

@ -197,8 +197,16 @@ M: callstack clone (clone) ;
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 -- )

2
core/lexer/lexer.factor
View File

@ -71,7 +71,7 @@ ERROR: unexpected want got ;
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.

2
core/math/bitfields/bitfields-tests.factor
View File

@ -14,4 +14,4 @@ IN: math.bitfields.tests
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
[ t ] [ \ foo compiled? ] unit-test
[ t ] [ \ foo compiled>> ] unit-test

4
core/math/math-docs.factor
View File

@ -302,11 +302,11 @@ HELP: fp-nan?
{ $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." } ;

6
core/math/math.factor
View File

@ -8,6 +8,12 @@ GENERIC: >bignum ( x -- n ) foldable
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 ;

6
core/mirrors/mirrors.factor
View File

@ -26,10 +26,10 @@ M: mirror at*
M: mirror set-at ( val key mirror -- )
[ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
dup writer>> [
nip offset>> set-slot
] [
dup read-only>> [
drop immutable-slot
] [
nip offset>> set-slot
] if
] [
drop no-such-slot

4
core/optimizer/def-use/def-use-tests.factor
View File

@ -91,7 +91,7 @@ namespaces assocs kernel sequences math tools.test words sets ;
{
[ 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 )
@ -121,6 +121,6 @@ namespaces assocs kernel sequences math tools.test words sets ;
] with assoc-each
]
}
\ regression-2 word-def kill-set
\ regression-2 def>> kill-set
[ member? ] curry map
] unit-test

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

@ -1,6 +1,6 @@
! 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
@ -37,7 +37,7 @@ DEFER: (flat-length)
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! inline
[ dup dup set word-def (flat-length) ]
[ dup dup set def>> (flat-length) ]
} cond ;
: (flat-length) ( seq -- n )
@ -51,7 +51,7 @@ DEFER: (flat-length)
] map sum ;
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;
[ def>> (flat-length) ] with-scope ;
! Single dispatch method inlining optimization
: node-class# ( node n -- class )
@ -201,7 +201,7 @@ DEFER: (flat-length)
: 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? [

4
core/optimizer/known-words/known-words.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
USING: accessors alien arrays generic hashtables inference.dataflow
inference.class kernel assocs math math.order math.private
kernel.private sequences words parser vectors strings sbufs io
namespaces assocs quotations sequences.private io.binary
@ -14,7 +14,7 @@ sequences.private combinators byte-arrays byte-vectors ;
{ <tuple> <tuple-boa> } [
[
dup node-in-d peek node-literal
dup tuple-layout? [ layout-class ] [ drop tuple ] if
dup tuple-layout? [ class>> ] [ drop tuple ] if
1array f
] "output-classes" set-word-prop
] each

2
core/optimizer/math/math.factor
View File

@ -256,7 +256,7 @@ optimizer.math.partial generic.standard system accessors ;
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] ]

12
core/optimizer/math/partial/partial.factor
View File

@ -1,6 +1,6 @@
! 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
@ -40,16 +40,16 @@ PREDICATE: math-partial < word
<<
: 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 ;
@ -86,7 +86,7 @@ PREDICATE: math-partial < word
{ 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

14
core/optimizer/optimizer-tests.factor
View File

@ -17,7 +17,7 @@ IN: optimizer.tests
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
[ t ] [ \ xyz compiled? ] unit-test
[ t ] [ \ xyz compiled>> ] unit-test
! Test predicate inlining
: pred-test-1
@ -102,7 +102,7 @@ TUPLE: pred-test ;
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage compiled? ] unit-test
[ t ] [ \ breakage compiled>> ] unit-test
[ breakage ] must-fail
! regression
@ -133,7 +133,7 @@ GENERIC: void-generic ( obj -- * )
! 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 ;
@ -247,7 +247,7 @@ TUPLE: silly-tuple a b ;
: 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
@ -271,7 +271,7 @@ TUPLE: silly-tuple a b ;
] 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
@ -309,7 +309,7 @@ M: integer generic-inline-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
@ -322,7 +322,7 @@ HINTS: recursive-inline-hang array ;
: 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

8
core/optimizer/specializers/specializers.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces sequences vectors words strings layouts combinators
sequences.private classes generic.standard
USING: accessors arrays generic hashtables kernel kernel.private
math namespaces sequences vectors words strings layouts
combinators sequences.private classes generic.standard
generic.standard.engines assocs ;
IN: optimizer.specializers
@ -51,7 +51,7 @@ IN: optimizer.specializers
] [ drop f ] if ;
: specialized-def ( word -- quot )
dup word-def swap {
dup def>> swap {
{ [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]

2
core/parser/parser.factor
View File

@ -81,7 +81,7 @@ M: no-word-error summary
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? [

16
core/prettyprint/backend/backend.factor
View File

@ -1,6 +1,6 @@
! 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
@ -37,7 +37,7 @@ M: effect pprint* effect>string "(" swap ")" 3append text ;
] keep ;
: word-name* ( word -- str )
word-name "( no name )" or ;
name>> "( no name )" or ;
: pprint-word ( word -- )
dup record-vocab
@ -117,7 +117,7 @@ M: pathname pprint*
: check-recursion ( obj quot -- )
nesting-limit? [
drop
"~" over class word-name "~" 3append
"~" over class name>> "~" 3append
swap present-text
] [
over recursion-check get memq? [
@ -166,7 +166,7 @@ M: curry >pprint-sequence ;
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 -- ? )
@ -190,19 +190,19 @@ M: tuple pprint-narrow? drop t ;
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 ;

6
core/prettyprint/prettyprint.factor
View File

@ -99,7 +99,7 @@ SYMBOL: ->
"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 )
[
@ -139,7 +139,7 @@ GENERIC: see ( defspec -- )
[ 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 ;
@ -214,7 +214,7 @@ GENERIC: declarations. ( obj -- )
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.
{

2
core/prettyprint/sections/sections.factor
View File

@ -20,7 +20,7 @@ TUPLE: pprinter last-newline line-count indent ;
: <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? ( -- ? )

27
core/quotations/quotations.factor
View File

@ -1,6 +1,6 @@
! 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
@ -12,16 +12,16 @@ M: curry call dup 3 slot swap 4 slot call ;
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
@ -38,28 +38,23 @@ M: object literalize ;
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

19
core/sbufs/sbufs.factor
View File

@ -1,9 +1,13 @@
! 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 )
@ -14,9 +18,10 @@ PRIVATE>
: <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
@ -35,8 +40,8 @@ M: string new-resizable drop <sbuf> ;
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

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

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math namespaces
USING: accessors arrays kernel kernel.private math namespaces
sequences strings words effects generic generic.standard
classes slots.private combinators slots ;
IN: slots.deprecated
@ -21,7 +21,7 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ;
[ set-reader-props ] 2keep
dup slot-spec-offset
over slot-spec-reader
rot slot-spec-type reader-quot
rot slot-spec-class reader-quot
define-slot-word
] [
2drop
@ -62,7 +62,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
>r [ swap "set-" % % "-" % % ] "" make r> create ;
: (simple-slot-word) ( class name -- class name vocab )
over word-vocabulary >r >r word-name r> r> ;
over vocabulary>> >r >r name>> r> r> ;
: simple-reader-word ( class name -- word )
(simple-slot-word) reader-word ;
@ -70,26 +70,8 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: simple-writer-word ( class name -- word )
(simple-slot-word) writer-word ;
: short-slot ( class name # -- spec )
>r object bootstrap-word over r> f f <slot-spec>
2over simple-reader-word over set-slot-spec-reader
-rot simple-writer-word over set-slot-spec-writer ;
: long-slot ( spec # -- spec )
>r [ dup array? [ first2 create ] when ] map first4 r>
-rot <slot-spec> ;
: simple-slots ( class slots base -- specs )
over length [ + ] with map [
{
{ [ over not ] [ 2drop f ] }
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
] 2map sift nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;
: slot-of-writer ( writer specs -- spec/f )
[ slot-spec-writer eq? ] with find nip ;
: deprecated-slots ( class slot-specs -- slot-specs' )
[
2dup name>> simple-reader-word >>reader
2dup name>> simple-writer-word >>writer
] map nip ;

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

@ -92,11 +92,11 @@ HELP: slot-spec
$nl
"The slots of a slot specification are:"
{ $list
{ { $link slot-spec-type } " - a " { $link class } " declaring the set of possible values for the slot." }
{ { $link slot-spec-name } " - a " { $link string } " identifying the slot." }
{ { $link slot-spec-offset } " - an " { $link integer } " offset specifying where the slot value is stored inside instances of the relevant class. This is an implementation detail." }
{ { $link slot-spec-reader } " - a " { $link word } " for reading the value of this slot." }
{ { $link slot-spec-writer } " - a " { $link word } " for writing the value of this slot." }
{ { $snippet "name" } " - a " { $link string } " identifying the slot." }
{ { $snippet "offset" } " - an " { $link integer } " offset specifying where the slot value is stored inside instances of the relevant class. This is an implementation detail." }
{ { $snippet "class" } " - a " { $link class } " declaring the set of possible values for the slot." }
{ { $snippet "initial" } " - an initial value for the slot." }
{ { $snippet "read-only" } " - a boolean indicating whether the slot is read only, or can be written to." }
} } ;
HELP: define-typecheck
@ -111,7 +111,7 @@ HELP: define-typecheck
}
"It checks if the top of the stack is an instance of " { $snippet "class" } ", and if so, executes the quotation. Delegation is respected."
}
{ $notes "This word is used internally to wrap low-level code that does not do type-checking in safe user-visible words. For example, see how " { $link word-name } " is implemented." } ;
{ $notes "This word is used internally to wrap unsafe low-level code in a type-checking stub." } ;
HELP: define-slot-word
{ $values { "class" class } { "slot" "a positive integer" } { "word" word } { "quot" quotation } }

18
core/slots/slots-tests.factor Normal file
View File

@ -0,0 +1,18 @@
IN: slots.tests
USING: math accessors slots strings generic.standard kernel tools.test ;
TUPLE: r/w-test foo ;
TUPLE: r/o-test { "foo" read-only: t } ;
[ r/o-test new 123 >>foo ] [ no-method? ] must-fail-with
TUPLE: decl-test { "foo" integer } ;
[ decl-test new 1.0 >>foo ] [ bad-slot-value? ] must-fail-with
TUPLE: hello length ;
[ 3 ] [ "xyz" length>> ] unit-test
[ "xyz" 4 >>length ] [ no-method? ] must-fail-with

100
core/slots/slots.factor
View File

@ -2,12 +2,14 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math namespaces
sequences strings words effects generic generic.standard
classes slots.private combinators accessors ;
classes slots.private combinators accessors words ;
IN: slots
TUPLE: slot-spec type name offset reader writer ;
TUPLE: slot-spec name offset class initial read-only reader writer ;
C: <slot-spec> slot-spec
: <slot-spec> ( -- slot-spec )
slot-spec new
object bootstrap-word >>class ;
: define-typecheck ( class generic quot -- )
[
@ -15,9 +17,13 @@ C: <slot-spec> slot-spec
create-method
] dip define ;
: define-slot-word ( class slot word quot -- )
: define-slot-word ( class offset word quot -- )
rot >fixnum prefix define-typecheck ;
: create-accessor ( name effect -- word )
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
: reader-quot ( decl -- quot )
[
\ slot ,
@ -25,15 +31,14 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
: create-accessor ( name effect -- word )
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
: reader-word ( name -- word )
">>" append (( object -- value )) create-accessor ;
: define-reader ( class slot name decl -- )
[ reader-word ] dip reader-quot define-slot-word ;
: define-reader ( class slot-spec -- )
[ offset>> ]
[ name>> reader-word ]
[ class>> reader-quot ]
tri define-slot-word ;
: writer-word ( name -- word )
"(>>" swap ")" 3append (( value object -- )) create-accessor ;
@ -50,22 +55,25 @@ ERROR: bad-slot-value value object index ;
] if
] [ ] make ;
: define-writer ( class slot name decl -- )
[ writer-word ] dip writer-quot define-slot-word ;
: define-writer ( class slot-spec -- )
[ offset>> ]
[ name>> writer-word ]
[ class>> writer-quot ]
tri define-slot-word ;
: setter-word ( name -- word )
">>" prepend (( object value -- object )) create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
: define-setter ( slot-spec -- )
name>> dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
: changer-word ( name -- word )
"change-" prepend (( object quot -- object )) create-accessor ;
: define-changer ( name -- )
dup changer-word dup deferred? [
: define-changer ( slot-spec -- )
name>> dup changer-word dup deferred? [
[
[ over >r >r ] %
over reader-word ,
@ -75,15 +83,63 @@ ERROR: bad-slot-value value object index ;
] [ 2drop ] if ;
: define-slot-methods ( class slot-spec -- )
{
[ [ drop ] [ name>> ] bi* define-changer ]
[ [ drop ] [ name>> ] bi* define-setter ]
[ [ offset>> ] [ name>> ] [ type>> ] tri define-reader ]
[ [ offset>> ] [ name>> ] [ type>> ] tri define-writer ]
} 2cleave ;
[ define-reader ]
[
dup read-only>> [ 2drop ] [
[ define-setter drop ]
[ define-changer drop ]
[ define-writer ]
2tri
] if
] 2bi ;
: define-accessors ( class specs -- )
[ define-slot-methods ] with each ;
: define-protocol-slot ( name -- )
{
[ reader-word drop ]
[ writer-word drop ]
[ setter-word drop ]
[ changer-word drop ]
} cleave ;
GENERIC: make-slot ( desc -- slot-spec )
M: string make-slot
<slot-spec>
swap >>name ;
: peel-off-name ( slot-spec array -- slot-spec array )
[ first >>name ] [ rest ] bi ; inline
: peel-off-class ( slot-spec array -- slot-spec array )
dup empty? [
! We'd use class? here, but during bootstrap, we sometimes
! create slots whose class hasn't been defined yet.
dup first name>> ":" tail? not [
[ first >>class ] [ rest ] bi
] when
] unless ;
: peel-off-attributes ( slot-spec array -- slot-spec array )
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
{ read-only: [ [ first >>read-only ] [ rest ] bi ] }
} case
] unless ;
M: array make-slot
<slot-spec>
swap
peel-off-name
peel-off-class
[ dup empty? not ] [ peel-off-attributes ] [ ] while drop ;
: make-slots ( slots base -- specs )
over length [ + ] with map
[ [ make-slot ] dip >>offset ] 2map ;
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;

6
core/sorting/sorting.factor
View File

@ -1,7 +1,7 @@
! 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
@ -34,7 +34,7 @@ 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

7
core/strings/strings.factor
View File

@ -1,6 +1,6 @@
! 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
@ -30,6 +30,9 @@ M: string hashcode*
nip dup string-hashcode [ ]
[ dup rehash-string string-hashcode ] ?if ;
M: string length
length>> ;
M: string nth-unsafe
>r >fixnum r> string-nth ;
@ -38,7 +41,7 @@ M: string set-nth-unsafe
>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 ;

42
core/syntax/syntax-docs.factor
View File

@ -547,8 +547,46 @@ HELP: PREDICATE:
HELP: TUPLE:
{ $syntax "TUPLE: class slots... ;" "TUPLE: class < superclass slots ... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
{ $description "Defines a new tuple class. The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." } ;
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot specifiers" } }
{ $description "Defines a new tuple class."
$nl
"The superclass is optional; if left unspecified, it defaults to " { $link tuple } "."
$nl
"Slot specifiers take one of the following three forms:"
{ $list
{ { $snippet "name" } " - a slot which can hold any object, with no attributes" }
{ { $snippet "{ \"name\" attributes... }" } " - a slot which can hold any object, with optional attributes" }
{ { $snippet "{ \"name\" class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
}
"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only: } "." }
{ $examples
"A simple tuple class:"
{ $code "TUPLE: color red green blue ;" }
"Declaring slots to be integer-valued:"
{ $code "TUPLE: color" "{ \"red\" integer }" "{ \"green\" integer }" "{ \"blue\" integer } ;" }
"An example mixing short and long slot specifiers:"
{ $code "TUPLE: person" "{ \"age\" integer initial: 0 }" "{ \"department\" string initial: \"Marketing\" }" "manager ;" }
} ;
HELP: initial:
{ $syntax "TUPLE: ... { \"slot\" initial: value } ... ;" }
{ $values { "slot" "a slot name" } { "value" "any literal" } }
{ $description "Specifies an initial value for a tuple slot." } ;
HELP: read-only:
{ $syntax "TUPLE: ... { \"slot\" read-only: ? } ... ;" }
{ $values { "slot" "a slot name" } { "?" "a boolean" } }
{ $description "Defines a tuple slot to be read-only. If a tuple has read-only slots, instances of the tuple should only be created by calling " { $link boa } ", instead of " { $link new } ". Using " { $link boa } " is the only way to set the value of a read-only slot." } ;
{ initial: read-only: } related-words
HELP: SLOT:
{ $syntax "SLOT: name" }
{ $values { "name" "a slot name" } }
{ $description "Defines a protocol slot; that is, defines the accessor words for a slot named " { $snippet "slot" } " without associating it with any specific tuple." }
{ $notes
"Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass."
} ;
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }

10
core/syntax/syntax.factor
View File

@ -8,7 +8,7 @@ generic.standard generic.math generic.parser classes io.files
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
@ -166,6 +166,10 @@ IN: bootstrap.syntax
parse-tuple-definition define-tuple-class
] define-syntax
"SLOT:" [
scan define-protocol-slot
] define-syntax
"C:" [
CREATE-WORD
scan-word check-tuple-class
@ -208,4 +212,8 @@ IN: bootstrap.syntax
not-in-a-method-error
] if
] define-syntax
"initial:" "syntax" lookup define-symbol
"read-only:" "syntax" lookup define-symbol
] with-compilation-unit

4
core/vectors/vectors.factor
View File

@ -3,6 +3,10 @@
USING: arrays kernel math sequences sequences.private growable ;
IN: vectors
TUPLE: vector
{ "underlying" array }
{ "length" array-capacity } ;
<PRIVATE
: array>vector ( array length -- vector )

36
core/words/words-docs.factor
View File

@ -11,10 +11,7 @@ $nl
"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" } "."
@ -103,8 +100,6 @@ ARTICLE: "word-props" "Word properties"
"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:"
@ -159,9 +154,8 @@ $nl
} ;
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 } ;
@ -189,10 +183,6 @@ $nl
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." }
@ -200,26 +190,6 @@ HELP: execute ( 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: } "." } ;

4
core/words/words-tests.factor
View File

@ -37,7 +37,7 @@ DEFER: plist-test
] with-scope
[ "test-scope" ] [
"test-scope" "scratchpad" lookup word-name
"test-scope" "scratchpad" lookup name>>
] unit-test
[ t ] [ vocabs array? ] unit-test
@ -120,7 +120,7 @@ DEFER: x
[ 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

41
core/words/words.factor
View File

@ -1,9 +1,9 @@
! 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 ;
@ -15,37 +15,36 @@ GENERIC: execute ( word -- )
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 ;
@ -53,7 +52,7 @@ M: primitive definition drop f ;
: lookup ( name vocab -- word ) vocab-words at ;
: target-word ( word -- target )
dup word-name swap word-vocabulary lookup ;
[ name>> ] [ vocabulary>> ] bi lookup ;
SYMBOL: bootstrapping?
@ -69,7 +68,7 @@ M: word crossref?
dup "forgotten" word-prop [
drop f
] [
word-vocabulary >boolean
vocabulary>> >boolean
] if ;
GENERIC: compiled-crossref? ( word -- ? )
@ -88,13 +87,13 @@ M: array (quot-uses) seq-uses ;
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
@ -140,7 +139,7 @@ M: object redefined drop ;
[ ] like
over unxref
over redefined
over set-word-def
>>def
dup +inlined+ changed-definition
dup crossref? [ dup xref ] when drop ;
@ -204,7 +203,7 @@ M: word subwords drop f ;
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 ;
@ -234,7 +233,7 @@ M: word set-where swap "loc" set-word-prop ;
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 ;
@ -244,6 +243,6 @@ M: word hashcode*
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 ;

2
extra/alias/alias.factor
View File

@ -7,7 +7,7 @@ M: alias reset-word
[ call-next-method ] [ f "alias" set-word-prop ] bi ;
M: alias stack-effect
word-def first stack-effect ;
def>> first stack-effect ;
: define-alias ( new old -- )
[ 1quotation define-inline ]

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

@ -5,15 +5,9 @@ sequences.private growable bit-arrays prettyprint.backend
parser accessors ;
IN: bit-vectors
TUPLE: bit-vector underlying fill ;
M: bit-vector underlying underlying>> { bit-array } declare ;
M: bit-vector set-underlying (>>underlying) ;
M: bit-vector length fill>> { array-capacity } declare ;
M: bit-vector set-fill (>>fill) ;
TUPLE: bit-vector
{ "underlying" bit-array }
{ "length" array-capacity } ;
<PRIVATE

2
extra/cpu/8080/emulator/emulator.factor
View File

@ -512,7 +512,7 @@ SYMBOL: rom-root
[ " 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 -- )

2
extra/db/queries/queries.factor
View File

@ -167,7 +167,7 @@ M: db <query> ( tuple class query -- tuple )
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 ;

4
extra/delegate/delegate.factor
View File

@ -1,6 +1,6 @@
! 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
@ -35,7 +35,7 @@ M: tuple-class group-words
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 ;

2
extra/descriptive/descriptive.factor
View File

@ -6,7 +6,7 @@ IN: descriptive
ERROR: descriptive-error args underlying word ;
M: descriptive-error summary
word>> "The " swap word-name " word encountered an error."
word>> "The " swap name>> " word encountered an error."
3append ;
<PRIVATE

6
extra/fjsc/fjsc.factor
View File

@ -322,10 +322,10 @@ M: number (parse-factor-quotation) ( object -- ast )
<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> ;
@ -346,7 +346,7 @@ M: hashtable (parse-factor-quotation) ( object -- ast )
] { } 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 )

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

@ -5,15 +5,9 @@ sequences.private growable float-arrays prettyprint.backend
parser accessors ;
IN: float-vectors
TUPLE: float-vector underlying fill ;
M: float-vector underlying underlying>> { float-array } declare ;
M: float-vector set-underlying (>>underlying) ;
M: float-vector length fill>> { array-capacity } declare ;
M: float-vector set-fill (>>fill) ;
TUPLE: float-vector
{ "underlying" float-array }
{ "length" array-capacity } ;
<PRIVATE

4
extra/furnace/furnace.factor
View File

@ -31,7 +31,7 @@ IN: furnace
: 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' )
@ -46,7 +46,7 @@ IN: furnace
: resolve-template-path ( pair -- path )
[
first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi*
first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
] "" make ;
GENERIC: modify-query ( query responder -- query' )

2
extra/furnace/utilities/utilities.factor
View File

@ -4,7 +4,7 @@ USING: 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 ;

12
extra/help/help.factor
View File

@ -1,8 +1,8 @@
! 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
@ -43,13 +43,13 @@ M: predicate word-help* drop \ $predicate ;
: 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 ;

17
extra/help/lint/lint.factor
View File

@ -1,7 +1,7 @@
! 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
@ -27,13 +27,10 @@ IN: help.lint
] 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 -- ? )
{

12
extra/help/markup/markup.factor
View File

@ -1,9 +1,9 @@
! 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.
@ -178,7 +178,7 @@ M: f print-element drop ;
first dup vocab-name swap ($vocab-link) ;
: $vocabulary ( element -- )
first word-vocabulary [
first vocabulary>> [
"Vocabulary" $heading nl dup ($vocab-link)
] when* ;
@ -230,7 +230,7 @@ M: f print-element drop ;
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 ;

4
extra/html/templates/chloe/syntax/syntax.factor
View File

@ -38,7 +38,7 @@ MEMO: chloe-name ( string -- name )
: CHLOE-SINGLETON:
scan-word
[ word-name ] [ '[ , singleton-component-tag ] ] bi
[ name>> ] [ '[ , singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
@ -56,6 +56,6 @@ MEMO: chloe-name ( string -- name )
: CHLOE-TUPLE:
scan-word
[ word-name ] [ '[ , tuple-component-tag ] ] bi
[ name>> ] [ '[ , tuple-component-tag ] ] bi
define-chloe-tag ;
parsing

2
extra/inverse/inverse.factor
View File

@ -80,7 +80,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
] } 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 } = ;

2
extra/io/unix/sockets/secure/secure-tests.factor
View File

@ -33,7 +33,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
"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

4
extra/io/unix/unix.factor
View File

@ -1,4 +1,4 @@
USING: system words sequences vocabs.loader ;
USING: accessors system words sequences vocabs.loader ;
{
"io.unix.backend"
@ -10,4 +10,4 @@ USING: system words sequences vocabs.loader ;
"io.unix.pipes"
} [ require ] each
"io.unix." os word-name append require
"io.unix." os name>> append require

2
extra/koszul/koszul.factor
View File

@ -41,7 +41,7 @@ SYMBOL: terms
nip number>string
] [
num-alt.
swap [ word-name ] map "." join
swap [ name>> ] map "." join
append
] if ;

Some files were not shown because too many files have changed in this diff Show More