Merge branch 'master' of git://factorcode.org/git/factor
commit
7b78269051
|
@ -1,6 +1,6 @@
|
||||||
USING: byte-arrays arrays help.syntax help.markup
|
USING: byte-arrays arrays help.syntax help.markup
|
||||||
alien.syntax compiler definitions math libc
|
alien.syntax compiler definitions math libc
|
||||||
debugger parser io io.backend system bit-arrays float-arrays
|
debugger parser io io.backend system
|
||||||
alien.accessors ;
|
alien.accessors ;
|
||||||
IN: alien
|
IN: alien
|
||||||
|
|
||||||
|
@ -10,7 +10,7 @@ HELP: alien
|
||||||
HELP: dll
|
HELP: dll
|
||||||
{ $class-description "The class of native library handles. See " { $link "syntax-aliens" } " for syntax and " { $link "dll.private" } " for general information." } ;
|
{ $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" } }
|
{ $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."
|
{ $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
|
$nl
|
||||||
|
@ -154,7 +154,11 @@ ARTICLE: "aliens" "Alien addresses"
|
||||||
{ $subsection expired? }
|
{ $subsection expired? }
|
||||||
"Anywhere that a " { $link alien } " instance is accepted, the " { $link f } " singleton may be passed in to denote a null pointer."
|
"Anywhere that a " { $link alien } " instance is accepted, the " { $link f } " singleton may be passed in to denote a null pointer."
|
||||||
$nl
|
$nl
|
||||||
"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details. See " { $link "c-types-specs" } "." ;
|
"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details."
|
||||||
|
{ $subsection "syntax-aliens" }
|
||||||
|
"When higher-level abstractions won't do:"
|
||||||
|
{ $subsection "reading-writing-memory" }
|
||||||
|
{ $see-also "c-data" "c-types-specs" } ;
|
||||||
|
|
||||||
ARTICLE: "reading-writing-memory" "Reading and writing memory directly"
|
ARTICLE: "reading-writing-memory" "Reading and writing memory directly"
|
||||||
"Numerical values can be read from memory addresses and converted to Factor objects using the various typed memory accessor words:"
|
"Numerical values can be read from memory addresses and converted to Factor objects using the various typed memory accessor words:"
|
||||||
|
@ -293,6 +297,7 @@ $nl
|
||||||
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
|
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
|
||||||
{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
|
{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
|
||||||
{ $subsection "loading-libs" }
|
{ $subsection "loading-libs" }
|
||||||
|
{ $subsection "aliens" }
|
||||||
{ $subsection "alien-invoke" }
|
{ $subsection "alien-invoke" }
|
||||||
{ $subsection "alien-callback" }
|
{ $subsection "alien-callback" }
|
||||||
{ $subsection "c-data" }
|
{ $subsection "c-data" }
|
||||||
|
|
|
@ -58,8 +58,6 @@ cell 8 = [
|
||||||
[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
|
[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
|
||||||
|
|
||||||
[ ] [ 0 B{ 1 2 3 } <displaced-alien> drop ] unit-test
|
[ ] [ 0 B{ 1 2 3 } <displaced-alien> drop ] unit-test
|
||||||
[ ] [ 0 F{ 1 2 3 } <displaced-alien> drop ] unit-test
|
|
||||||
[ ] [ 0 ?{ t f t } <displaced-alien> drop ] unit-test
|
|
||||||
|
|
||||||
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] must-fail
|
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] must-fail
|
||||||
|
|
||||||
|
|
|
@ -1,33 +1,35 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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 ;
|
kernel.private byte-arrays arrays ;
|
||||||
IN: alien
|
IN: alien
|
||||||
|
|
||||||
! Some predicate classes used by the compiler for optimization
|
! Some predicate classes used by the compiler for optimization
|
||||||
! purposes
|
! purposes
|
||||||
PREDICATE: simple-alien < alien
|
PREDICATE: simple-alien < alien underlying>> not ;
|
||||||
underlying-alien not ;
|
|
||||||
|
|
||||||
UNION: simple-c-ptr
|
UNION: simple-c-ptr
|
||||||
simple-alien POSTPONE: f byte-array bit-array float-array ;
|
simple-alien POSTPONE: f byte-array ;
|
||||||
|
|
||||||
UNION: c-ptr
|
|
||||||
alien POSTPONE: f byte-array bit-array float-array ;
|
|
||||||
|
|
||||||
DEFER: pinned-c-ptr?
|
DEFER: pinned-c-ptr?
|
||||||
|
|
||||||
PREDICATE: pinned-alien < alien
|
PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
|
||||||
underlying-alien pinned-c-ptr? ;
|
|
||||||
|
|
||||||
UNION: pinned-c-ptr
|
UNION: pinned-c-ptr
|
||||||
pinned-alien POSTPONE: f ;
|
pinned-alien POSTPONE: f ;
|
||||||
|
|
||||||
|
GENERIC: expired? ( c-ptr -- ? ) flushable
|
||||||
|
|
||||||
|
M: alien expired? expired>> ;
|
||||||
|
|
||||||
M: f expired? drop t ;
|
M: f expired? drop t ;
|
||||||
|
|
||||||
: <alien> ( address -- alien )
|
: <alien> ( address -- alien )
|
||||||
f <displaced-alien> { simple-c-ptr } declare ; inline
|
f <displaced-alien> { simple-c-ptr } declare ; inline
|
||||||
|
|
||||||
|
: <bad-alien> ( -- alien )
|
||||||
|
-1 <alien> t >>expired ; inline
|
||||||
|
|
||||||
M: alien equal?
|
M: alien equal?
|
||||||
over alien? [
|
over alien? [
|
||||||
2dup [ expired? ] either? [
|
2dup [ expired? ] either? [
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: alien.c-types
|
IN: alien.c-types
|
||||||
USING: alien help.syntax help.markup libc kernel.private
|
USING: alien help.syntax help.markup libc kernel.private
|
||||||
byte-arrays math strings hashtables alien.syntax
|
byte-arrays math strings hashtables alien.syntax
|
||||||
bit-arrays float-arrays debugger destructors ;
|
debugger destructors ;
|
||||||
|
|
||||||
HELP: <c-type>
|
HELP: <c-type>
|
||||||
{ $values { "type" hashtable } }
|
{ $values { "type" hashtable } }
|
||||||
|
@ -200,7 +200,7 @@ $nl
|
||||||
"Structure and union types are specified by the name of the structure or union." ;
|
"Structure and union types are specified by the name of the structure or union." ;
|
||||||
|
|
||||||
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
|
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
|
||||||
"Instances of the " { $link byte-array } ", " { $link bit-array } " and " { $link float-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
|
"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
|
||||||
$nl
|
$nl
|
||||||
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
|
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
|
||||||
{ $subsection <c-object> }
|
{ $subsection <c-object> }
|
||||||
|
@ -253,4 +253,4 @@ $nl
|
||||||
"New C types can be defined:"
|
"New C types can be defined:"
|
||||||
{ $subsection "c-structs" }
|
{ $subsection "c-structs" }
|
||||||
{ $subsection "c-unions" }
|
{ $subsection "c-unions" }
|
||||||
{ $subsection "reading-writing-memory" } ;
|
{ $see-also "aliens" } ;
|
||||||
|
|
|
@ -1,7 +1,6 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: bit-arrays byte-arrays float-arrays arrays
|
USING: byte-arrays arrays assocs kernel kernel.private libc math
|
||||||
assocs kernel kernel.private libc math
|
|
||||||
namespaces parser sequences strings words assocs splitting
|
namespaces parser sequences strings words assocs splitting
|
||||||
math.parser cpu.architecture alien alien.accessors quotations
|
math.parser cpu.architecture alien alien.accessors quotations
|
||||||
layouts system compiler.units io.files io.encodings.binary
|
layouts system compiler.units io.files io.encodings.binary
|
||||||
|
@ -118,12 +117,8 @@ M: c-type stack-size c-type-size ;
|
||||||
|
|
||||||
GENERIC: byte-length ( seq -- n ) flushable
|
GENERIC: byte-length ( seq -- n ) flushable
|
||||||
|
|
||||||
M: bit-array byte-length length 7 + -3 shift ;
|
|
||||||
|
|
||||||
M: byte-array byte-length length ;
|
M: byte-array byte-length length ;
|
||||||
|
|
||||||
M: float-array byte-length length "double" heap-size * ;
|
|
||||||
|
|
||||||
: c-getter ( name -- quot )
|
: c-getter ( name -- quot )
|
||||||
c-type c-type-getter [
|
c-type c-type-getter [
|
||||||
[ "Cannot read struct fields with type" throw ]
|
[ "Cannot read struct fields with type" throw ]
|
||||||
|
@ -242,11 +237,10 @@ M: long-long-type box-return ( type -- )
|
||||||
} 2cleave ;
|
} 2cleave ;
|
||||||
|
|
||||||
: expand-constants ( c-type -- c-type' )
|
: 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
|
#! staging violations
|
||||||
dup array? [
|
dup array? [
|
||||||
unclip >r [ dup word? [ word-def call ] when ] map
|
unclip >r [ dup word? [ def>> call ] when ] map r> prefix
|
||||||
r> prefix
|
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: malloc-file-contents ( path -- alien len )
|
: malloc-file-contents ( path -- alien len )
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: arrays generator generator.registers generator.fixup
|
||||||
hashtables kernel math namespaces sequences words
|
hashtables kernel math namespaces sequences words
|
||||||
inference.state inference.backend inference.dataflow system
|
inference.state inference.backend inference.dataflow system
|
||||||
math.parser classes alien.arrays alien.c-types alien.strings
|
math.parser classes alien.arrays alien.c-types alien.strings
|
||||||
alien.structs alien.syntax cpu.architecture alien inspector
|
alien.structs alien.syntax cpu.architecture alien summary
|
||||||
quotations assocs kernel.private threads continuations.private
|
quotations assocs kernel.private threads continuations.private
|
||||||
libc combinators compiler.errors continuations layouts accessors
|
libc combinators compiler.errors continuations layouts accessors
|
||||||
init sets ;
|
init sets ;
|
||||||
|
@ -161,16 +161,8 @@ M: long-long-type flatten-value-type ( type -- )
|
||||||
dup return>> "void" = 0 1 ?
|
dup return>> "void" = 0 1 ?
|
||||||
swap produce-values ;
|
swap produce-values ;
|
||||||
|
|
||||||
: (param-prep-quot) ( parameters -- )
|
|
||||||
dup empty? [
|
|
||||||
drop
|
|
||||||
] [
|
|
||||||
unclip c-type c-type-unboxer-quot %
|
|
||||||
\ >r , (param-prep-quot) \ r> ,
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: param-prep-quot ( node -- quot )
|
: param-prep-quot ( node -- quot )
|
||||||
parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
|
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
|
||||||
|
|
||||||
: unbox-parameters ( offset node -- )
|
: unbox-parameters ( offset node -- )
|
||||||
parameters>> [
|
parameters>> [
|
||||||
|
@ -198,19 +190,11 @@ M: long-long-type flatten-value-type ( type -- )
|
||||||
: box-return* ( node -- )
|
: box-return* ( node -- )
|
||||||
return>> [ ] [ box-return ] if-void ;
|
return>> [ ] [ box-return ] if-void ;
|
||||||
|
|
||||||
: (return-prep-quot) ( parameters -- )
|
|
||||||
dup empty? [
|
|
||||||
drop
|
|
||||||
] [
|
|
||||||
unclip c-type c-type-boxer-quot %
|
|
||||||
\ >r , (return-prep-quot) \ r> ,
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: callback-prep-quot ( node -- quot )
|
: callback-prep-quot ( node -- quot )
|
||||||
parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
|
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
|
||||||
|
|
||||||
: return-prep-quot ( node -- quot )
|
: return-prep-quot ( node -- quot )
|
||||||
[ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
|
return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
|
||||||
|
|
||||||
M: alien-invoke-error summary
|
M: alien-invoke-error summary
|
||||||
drop
|
drop
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.strings parser threads words
|
USING: accessors alien alien.c-types alien.strings parser
|
||||||
kernel.private kernel io.encodings.utf8 ;
|
threads words kernel.private kernel io.encodings.utf8 ;
|
||||||
IN: alien.remote-control
|
IN: alien.remote-control
|
||||||
|
|
||||||
: eval-callback ( -- callback )
|
: eval-callback ( -- callback )
|
||||||
|
@ -15,7 +15,7 @@ IN: alien.remote-control
|
||||||
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
||||||
|
|
||||||
: ?callback ( word -- alien )
|
: ?callback ( word -- alien )
|
||||||
dup compiled? [ execute ] [ drop f ] if ; inline
|
dup compiled>> [ execute ] [ drop f ] if ; inline
|
||||||
|
|
||||||
: init-remote-control ( -- )
|
: init-remote-control ( -- )
|
||||||
\ eval-callback ?callback 16 setenv
|
\ eval-callback ?callback 16 setenv
|
||||||
|
|
|
@ -100,7 +100,7 @@ M: utf16n <encoder> drop utf16n <encoder> ;
|
||||||
os windows? [ utf16n ] [ utf8 ] if alien>string ;
|
os windows? [ utf16n ] [ utf8 ] if alien>string ;
|
||||||
|
|
||||||
: dll-path ( dll -- string )
|
: dll-path ( dll -- string )
|
||||||
(dll-path) alien>native-string ;
|
path>> alien>native-string ;
|
||||||
|
|
||||||
: string>symbol ( str -- alien )
|
: string>symbol ( str -- alien )
|
||||||
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
|
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
|
||||||
|
|
|
@ -7,7 +7,7 @@ kernel words slots assocs namespaces ;
|
||||||
: ($spec-reader-values) ( slot-spec class -- element )
|
: ($spec-reader-values) ( slot-spec class -- element )
|
||||||
dup ?word-name swap 2array
|
dup ?word-name swap 2array
|
||||||
over slot-spec-name
|
over slot-spec-name
|
||||||
rot slot-spec-type 2array 2array
|
rot slot-spec-class 2array 2array
|
||||||
[ { $instance } swap suffix ] assoc-map ;
|
[ { $instance } swap suffix ] assoc-map ;
|
||||||
|
|
||||||
: $spec-reader-values ( slot-spec class -- )
|
: $spec-reader-values ( slot-spec class -- )
|
||||||
|
@ -22,6 +22,9 @@ kernel words slots assocs namespaces ;
|
||||||
" instance." ,
|
" instance." ,
|
||||||
] { } make $description ;
|
] { } make $description ;
|
||||||
|
|
||||||
|
: slot-of-reader ( reader specs -- spec/f )
|
||||||
|
[ slot-spec-reader eq? ] with find nip ;
|
||||||
|
|
||||||
: $spec-reader ( reader slot-specs class -- )
|
: $spec-reader ( reader slot-specs class -- )
|
||||||
>r slot-of-reader r>
|
>r slot-of-reader r>
|
||||||
over [
|
over [
|
||||||
|
@ -49,6 +52,9 @@ M: word slot-specs "slots" word-prop ;
|
||||||
" instance." ,
|
" instance." ,
|
||||||
] { } make $description ;
|
] { } make $description ;
|
||||||
|
|
||||||
|
: slot-of-writer ( writer specs -- spec/f )
|
||||||
|
[ slot-spec-writer eq? ] with find nip ;
|
||||||
|
|
||||||
: $spec-writer ( writer slot-specs class -- )
|
: $spec-writer ( writer slot-specs class -- )
|
||||||
>r slot-of-writer r>
|
>r slot-of-writer r>
|
||||||
over [
|
over [
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004, 2007 Slava Pestov.
|
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays generic hashtables kernel kernel.private math
|
USING: accessors arrays generic hashtables kernel kernel.private
|
||||||
namespaces parser sequences strings words libc slots
|
math namespaces parser sequences strings words libc slots
|
||||||
slots.deprecated alien.c-types cpu.architecture ;
|
slots.deprecated alien.c-types cpu.architecture ;
|
||||||
IN: alien.structs
|
IN: alien.structs
|
||||||
|
|
||||||
|
@ -10,9 +10,9 @@ IN: alien.structs
|
||||||
|
|
||||||
: struct-offsets ( specs -- size )
|
: struct-offsets ( specs -- size )
|
||||||
0 [
|
0 [
|
||||||
[ slot-spec-type align-offset ] keep
|
[ class>> align-offset ] keep
|
||||||
[ set-slot-spec-offset ] 2keep
|
[ set-slot-spec-offset ] 2keep
|
||||||
slot-spec-type heap-size +
|
class>> heap-size +
|
||||||
] reduce ;
|
] reduce ;
|
||||||
|
|
||||||
: define-struct-slot-word ( spec word quot -- )
|
: define-struct-slot-word ( spec word quot -- )
|
||||||
|
@ -23,7 +23,7 @@ IN: alien.structs
|
||||||
[ ]
|
[ ]
|
||||||
[ slot-spec-reader ]
|
[ slot-spec-reader ]
|
||||||
[
|
[
|
||||||
slot-spec-type
|
class>>
|
||||||
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
|
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
|
||||||
] tri
|
] tri
|
||||||
define-struct-slot-word ;
|
define-struct-slot-word ;
|
||||||
|
@ -32,7 +32,7 @@ IN: alien.structs
|
||||||
[ set-writer-props ] keep
|
[ set-writer-props ] keep
|
||||||
[ ]
|
[ ]
|
||||||
[ slot-spec-writer ]
|
[ slot-spec-writer ]
|
||||||
[ slot-spec-type c-setter ] tri
|
[ class>> c-setter ] tri
|
||||||
define-struct-slot-word ;
|
define-struct-slot-word ;
|
||||||
|
|
||||||
: define-field ( type spec -- )
|
: define-field ( type spec -- )
|
||||||
|
@ -77,13 +77,13 @@ M: struct-type stack-size
|
||||||
-rot define-c-type ;
|
-rot define-c-type ;
|
||||||
|
|
||||||
: make-field ( struct-name vocab type field-name -- spec )
|
: make-field ( struct-name vocab type field-name -- spec )
|
||||||
[
|
<slot-spec>
|
||||||
-rot expand-constants ,
|
0 >>offset
|
||||||
over ,
|
swap >>name
|
||||||
3dup reader-word ,
|
swap expand-constants >>class
|
||||||
writer-word ,
|
3dup name>> swap reader-word >>reader
|
||||||
] { } make
|
3dup name>> swap writer-word >>writer
|
||||||
first4 0 -rot <slot-spec> ;
|
2nip ;
|
||||||
|
|
||||||
: define-struct-early ( name vocab fields -- fields )
|
: define-struct-early ( name vocab fields -- fields )
|
||||||
-rot [ rot first2 make-field ] 2curry map ;
|
-rot [ rot first2 make-field ] 2curry map ;
|
||||||
|
@ -94,7 +94,7 @@ M: struct-type stack-size
|
||||||
: define-struct ( name vocab fields -- )
|
: define-struct ( name vocab fields -- )
|
||||||
pick >r
|
pick >r
|
||||||
[ struct-offsets ] keep
|
[ struct-offsets ] keep
|
||||||
[ [ slot-spec-type ] map compute-struct-align ] keep
|
[ [ class>> ] map compute-struct-align ] keep
|
||||||
[ (define-struct) ] keep
|
[ (define-struct) ] keep
|
||||||
r> [ swap define-field ] curry each ;
|
r> [ swap define-field ] curry each ;
|
||||||
|
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
|
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays alien alien.c-types alien.structs alien.arrays
|
USING: accessors arrays alien alien.c-types alien.structs
|
||||||
alien.strings kernel math namespaces parser sequences words
|
alien.arrays alien.strings kernel math namespaces parser
|
||||||
quotations math.parser splitting grouping effects prettyprint
|
sequences words quotations math.parser splitting grouping
|
||||||
prettyprint.sections prettyprint.backend assocs combinators
|
effects prettyprint prettyprint.sections prettyprint.backend
|
||||||
lexer strings.parser ;
|
assocs combinators lexer strings.parser ;
|
||||||
IN: alien.syntax
|
IN: alien.syntax
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
@ -37,6 +37,8 @@ PRIVATE>
|
||||||
|
|
||||||
: ALIEN: scan string>number <alien> parsed ; parsing
|
: ALIEN: scan string>number <alien> parsed ; parsing
|
||||||
|
|
||||||
|
: BAD-ALIEN <bad-alien> parsed ; parsing
|
||||||
|
|
||||||
: LIBRARY: scan "c-library" set ; parsing
|
: LIBRARY: scan "c-library" set ; parsing
|
||||||
|
|
||||||
: FUNCTION:
|
: FUNCTION:
|
||||||
|
@ -67,7 +69,7 @@ PRIVATE>
|
||||||
|
|
||||||
M: alien pprint*
|
M: alien pprint*
|
||||||
{
|
{
|
||||||
{ [ dup expired? ] [ drop "( alien expired )" text ] }
|
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
|
||||||
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
|
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
|
||||||
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
|
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: arrays kernel sequences sequences.private growable
|
USING: accessors arrays kernel sequences sequences.private growable
|
||||||
tools.test vectors layouts system math vectors.private ;
|
tools.test vectors layouts system math vectors.private ;
|
||||||
IN: arrays.tests
|
IN: arrays.tests
|
||||||
|
|
||||||
|
@ -11,7 +11,7 @@ IN: arrays.tests
|
||||||
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
|
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
|
||||||
[ f ] [ { "a" "b" "c" } dup >array eq? ] unit-test
|
[ f ] [ { "a" "b" "c" } dup >array eq? ] unit-test
|
||||||
[ t ] [ { "a" "b" "c" } dup { } like eq? ] unit-test
|
[ t ] [ { "a" "b" "c" } dup { } like eq? ] unit-test
|
||||||
[ t ] [ { "a" "b" "c" } dup dup length array>vector underlying eq? ] unit-test
|
[ t ] [ { "a" "b" "c" } dup dup length vector boa underlying>> eq? ] unit-test
|
||||||
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } V{ } like ] unit-test
|
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } V{ } like ] unit-test
|
||||||
[ { "a" "b" "c" } ] [ { "a" } { "b" "c" } append ] unit-test
|
[ { "a" "b" "c" } ] [ { "a" } { "b" "c" } append ] unit-test
|
||||||
[ { "a" "b" "c" "d" "e" } ]
|
[ { "a" "b" "c" "d" "e" } ]
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: assocs.tests
|
IN: assocs.tests
|
||||||
USING: kernel math namespaces tools.test vectors sequences
|
USING: kernel math namespaces tools.test vectors sequences
|
||||||
sequences.private hashtables io prettyprint assocs
|
sequences.private hashtables io prettyprint assocs
|
||||||
continuations ;
|
continuations float-arrays ;
|
||||||
|
|
||||||
[ t ] [ H{ } dup assoc-subset? ] unit-test
|
[ t ] [ H{ } dup assoc-subset? ] unit-test
|
||||||
[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
|
[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
|
||||||
|
|
|
@ -1,67 +0,0 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: math alien.accessors kernel kernel.private sequences
|
|
||||||
sequences.private ;
|
|
||||||
IN: bit-arrays
|
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
: n>byte -3 shift ; inline
|
|
||||||
|
|
||||||
: byte/bit ( n alien -- byte bit )
|
|
||||||
over n>byte alien-unsigned-1 swap 7 bitand ; inline
|
|
||||||
|
|
||||||
: set-bit ( ? byte bit -- byte )
|
|
||||||
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
|
|
||||||
|
|
||||||
: bits>cells 31 + -5 shift ; inline
|
|
||||||
|
|
||||||
: (set-bits) ( bit-array n -- )
|
|
||||||
over length bits>cells -rot [
|
|
||||||
spin 4 * set-alien-unsigned-4
|
|
||||||
] 2curry each ; inline
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
M: bit-array length array-capacity ;
|
|
||||||
|
|
||||||
M: bit-array nth-unsafe
|
|
||||||
>r >fixnum r> byte/bit bit? ;
|
|
||||||
|
|
||||||
M: bit-array set-nth-unsafe
|
|
||||||
>r >fixnum r>
|
|
||||||
[ byte/bit set-bit ] 2keep
|
|
||||||
swap n>byte set-alien-unsigned-1 ;
|
|
||||||
|
|
||||||
: clear-bits ( bit-array -- ) 0 (set-bits) ;
|
|
||||||
|
|
||||||
: set-bits ( bit-array -- ) -1 (set-bits) ;
|
|
||||||
|
|
||||||
M: bit-array clone (clone) ;
|
|
||||||
|
|
||||||
: >bit-array ( seq -- bit-array ) ?{ } clone-like ; inline
|
|
||||||
|
|
||||||
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
|
|
||||||
|
|
||||||
M: bit-array new-sequence drop <bit-array> ;
|
|
||||||
|
|
||||||
M: bit-array equal?
|
|
||||||
over bit-array? [ sequence= ] [ 2drop f ] if ;
|
|
||||||
|
|
||||||
M: bit-array resize
|
|
||||||
resize-bit-array ;
|
|
||||||
|
|
||||||
: integer>bit-array ( int -- bit-array )
|
|
||||||
[ log2 1+ <bit-array> 0 ] keep
|
|
||||||
[ dup zero? not ] [
|
|
||||||
[ -8 shift ] [ 255 bitand ] bi
|
|
||||||
-roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip
|
|
||||||
] [ ] while
|
|
||||||
2drop ;
|
|
||||||
|
|
||||||
: bit-array>integer ( bit-array -- int )
|
|
||||||
dup >r length 7 + n>byte 0 r> [
|
|
||||||
swap alien-unsigned-1 swap 8 shift bitor
|
|
||||||
] curry reduce ;
|
|
||||||
|
|
||||||
INSTANCE: bit-array sequence
|
|
|
@ -1,11 +1,12 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: compiler cpu.architecture vocabs.loader system sequences
|
USING: accessors compiler cpu.architecture vocabs.loader system
|
||||||
namespaces parser kernel kernel.private classes classes.private
|
sequences namespaces parser kernel kernel.private classes
|
||||||
arrays hashtables vectors classes.tuple sbufs inference.dataflow
|
classes.private arrays hashtables vectors classes.tuple sbufs
|
||||||
hashtables.private sequences.private math classes.tuple.private
|
inference.dataflow hashtables.private sequences.private math
|
||||||
growable namespaces.private assocs words generator command-line
|
classes.tuple.private growable namespaces.private assocs words
|
||||||
vocabs io prettyprint libc compiler.units math.order ;
|
generator command-line vocabs io prettyprint libc compiler.units
|
||||||
|
math.order ;
|
||||||
IN: bootstrap.compiler
|
IN: bootstrap.compiler
|
||||||
|
|
||||||
! Don't bring this in when deploying, since it will store a
|
! Don't bring this in when deploying, since it will store a
|
||||||
|
@ -14,12 +15,12 @@ IN: bootstrap.compiler
|
||||||
"alien.remote-control" require
|
"alien.remote-control" require
|
||||||
] unless
|
] unless
|
||||||
|
|
||||||
"cpu." cpu word-name append require
|
"cpu." cpu name>> append require
|
||||||
|
|
||||||
enable-compiler
|
enable-compiler
|
||||||
|
|
||||||
: compile-uncompiled ( words -- )
|
: compile-uncompiled ( words -- )
|
||||||
[ compiled? not ] filter compile ;
|
[ compiled>> not ] filter compile ;
|
||||||
|
|
||||||
nl
|
nl
|
||||||
"Compiling..." write flush
|
"Compiling..." write flush
|
||||||
|
@ -40,10 +41,12 @@ nl
|
||||||
|
|
||||||
wrap probe
|
wrap probe
|
||||||
|
|
||||||
underlying
|
|
||||||
|
|
||||||
namestack*
|
namestack*
|
||||||
|
} compile-uncompiled
|
||||||
|
|
||||||
|
"." write flush
|
||||||
|
|
||||||
|
{
|
||||||
bitand bitor bitxor bitnot
|
bitand bitor bitxor bitnot
|
||||||
} compile-uncompiled
|
} compile-uncompiled
|
||||||
|
|
||||||
|
|
|
@ -1,19 +1,19 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien arrays bit-arrays byte-arrays generic assocs
|
USING: alien arrays byte-arrays generic assocs hashtables assocs
|
||||||
hashtables assocs hashtables.private io kernel kernel.private
|
hashtables.private io kernel kernel.private math namespaces
|
||||||
math namespaces parser prettyprint sequences sequences.private
|
parser prettyprint sequences sequences.private strings sbufs
|
||||||
strings sbufs vectors words quotations assocs system layouts
|
vectors words quotations assocs system layouts splitting
|
||||||
splitting grouping growable classes classes.builtin classes.tuple
|
grouping growable classes classes.builtin classes.tuple
|
||||||
classes.tuple.private words.private io.binary io.files vocabs
|
classes.tuple.private words.private io.binary io.files vocabs
|
||||||
vocabs.loader source-files definitions debugger float-arrays
|
vocabs.loader source-files definitions debugger
|
||||||
quotations.private sequences.private combinators
|
quotations.private sequences.private combinators
|
||||||
io.encodings.binary math.order accessors ;
|
io.encodings.binary math.order accessors ;
|
||||||
IN: bootstrap.image
|
IN: bootstrap.image
|
||||||
|
|
||||||
: my-arch ( -- arch )
|
: my-arch ( -- arch )
|
||||||
cpu word-name
|
cpu name>>
|
||||||
dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
|
dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
|
||||||
|
|
||||||
: boot-image-name ( arch -- string )
|
: boot-image-name ( arch -- string )
|
||||||
"boot." swap ".image" 3append ;
|
"boot." swap ".image" 3append ;
|
||||||
|
@ -260,10 +260,10 @@ M: f '
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
[ hashcode , ]
|
[ hashcode , ]
|
||||||
[ word-name , ]
|
[ name>> , ]
|
||||||
[ word-vocabulary , ]
|
[ vocabulary>> , ]
|
||||||
[ word-def , ]
|
[ def>> , ]
|
||||||
[ word-props , ]
|
[ props>> , ]
|
||||||
} cleave
|
} cleave
|
||||||
f ,
|
f ,
|
||||||
0 , ! count
|
0 , ! count
|
||||||
|
@ -277,7 +277,7 @@ M: f '
|
||||||
] keep put-object ;
|
] keep put-object ;
|
||||||
|
|
||||||
: word-error ( word msg -- * )
|
: word-error ( word msg -- * )
|
||||||
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
|
[ % dup vocabulary>> % " " % name>> % ] "" make throw ;
|
||||||
|
|
||||||
: transfer-word ( word -- word )
|
: transfer-word ( word -- word )
|
||||||
[ target-word ] keep or ;
|
[ target-word ] keep or ;
|
||||||
|
@ -294,7 +294,7 @@ M: word ' ;
|
||||||
! Wrappers
|
! Wrappers
|
||||||
|
|
||||||
M: wrapper '
|
M: wrapper '
|
||||||
wrapped ' wrapper type-number object tag-number
|
wrapped>> ' wrapper type-number object tag-number
|
||||||
[ emit ] emit-object ;
|
[ emit ] emit-object ;
|
||||||
|
|
||||||
! Strings
|
! Strings
|
||||||
|
@ -334,10 +334,6 @@ M: byte-array '
|
||||||
pad-bytes emit-bytes
|
pad-bytes emit-bytes
|
||||||
] emit-object ;
|
] emit-object ;
|
||||||
|
|
||||||
M: bit-array ' bit-array emit-dummy-array ;
|
|
||||||
|
|
||||||
M: float-array ' float-array emit-dummy-array ;
|
|
||||||
|
|
||||||
! Tuples
|
! Tuples
|
||||||
: (emit-tuple) ( tuple -- pointer )
|
: (emit-tuple) ( tuple -- pointer )
|
||||||
[ tuple>array rest-slice ]
|
[ tuple>array rest-slice ]
|
||||||
|
@ -345,7 +341,7 @@ M: float-array ' float-array emit-dummy-array ;
|
||||||
tuple type-number dup [ emit-seq ] emit-object ;
|
tuple type-number dup [ emit-seq ] emit-object ;
|
||||||
|
|
||||||
: emit-tuple ( tuple -- pointer )
|
: emit-tuple ( tuple -- pointer )
|
||||||
dup class word-name "tombstone" =
|
dup class name>> "tombstone" =
|
||||||
[ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
|
[ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
|
||||||
|
|
||||||
M: tuple ' emit-tuple ;
|
M: tuple ' emit-tuple ;
|
||||||
|
@ -354,11 +350,11 @@ M: tuple-layout '
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
[ layout-hashcode , ]
|
[ hashcode>> , ]
|
||||||
[ layout-class , ]
|
[ class>> , ]
|
||||||
[ layout-size , ]
|
[ size>> , ]
|
||||||
[ layout-superclasses , ]
|
[ superclasses>> , ]
|
||||||
[ layout-echelon , ]
|
[ echelon>> , ]
|
||||||
} cleave
|
} cleave
|
||||||
] { } make [ ' ] map
|
] { } make [ ' ] map
|
||||||
\ tuple-layout type-number
|
\ tuple-layout type-number
|
||||||
|
@ -368,7 +364,7 @@ M: tuple-layout '
|
||||||
M: tombstone '
|
M: tombstone '
|
||||||
delegate
|
delegate
|
||||||
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
||||||
word-def first [ emit-tuple ] cache-object ;
|
def>> first [ emit-tuple ] cache-object ;
|
||||||
|
|
||||||
! Arrays
|
! Arrays
|
||||||
M: array '
|
M: array '
|
||||||
|
@ -379,10 +375,10 @@ M: array '
|
||||||
|
|
||||||
M: quotation '
|
M: quotation '
|
||||||
[
|
[
|
||||||
quotation-array '
|
array>> '
|
||||||
quotation type-number object tag-number [
|
quotation type-number object tag-number [
|
||||||
emit ! array
|
emit ! array
|
||||||
f ' emit ! compiled?
|
f ' emit ! compiled>>
|
||||||
0 emit ! xt
|
0 emit ! xt
|
||||||
0 emit ! code
|
0 emit ! code
|
||||||
] emit-object
|
] emit-object
|
||||||
|
|
|
@ -1,15 +1,15 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: namespaces math words kernel alien byte-arrays
|
USING: namespaces math words kernel alien byte-arrays
|
||||||
hashtables vectors strings sbufs arrays bit-arrays
|
hashtables vectors strings sbufs arrays
|
||||||
float-arrays quotations assocs layouts classes.tuple.private
|
quotations assocs layouts classes.tuple.private
|
||||||
kernel.private ;
|
kernel.private ;
|
||||||
|
|
||||||
BIN: 111 tag-mask set
|
BIN: 111 tag-mask set
|
||||||
8 num-tags set
|
8 num-tags set
|
||||||
3 tag-bits set
|
3 tag-bits set
|
||||||
|
|
||||||
20 num-types set
|
18 num-types set
|
||||||
|
|
||||||
H{
|
H{
|
||||||
{ fixnum BIN: 000 }
|
{ fixnum BIN: 000 }
|
||||||
|
@ -26,14 +26,12 @@ H{
|
||||||
tag-numbers get H{
|
tag-numbers get H{
|
||||||
{ array 8 }
|
{ array 8 }
|
||||||
{ wrapper 9 }
|
{ wrapper 9 }
|
||||||
{ float-array 10 }
|
{ byte-array 10 }
|
||||||
{ callstack 11 }
|
{ callstack 11 }
|
||||||
{ string 12 }
|
{ string 12 }
|
||||||
{ bit-array 13 }
|
{ tuple-layout 13 }
|
||||||
{ quotation 14 }
|
{ quotation 14 }
|
||||||
{ dll 15 }
|
{ dll 15 }
|
||||||
{ alien 16 }
|
{ alien 16 }
|
||||||
{ word 17 }
|
{ word 17 }
|
||||||
{ byte-array 18 }
|
|
||||||
{ tuple-layout 19 }
|
|
||||||
} assoc-union type-numbers set
|
} assoc-union type-numbers set
|
||||||
|
|
|
@ -1,13 +1,12 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien arrays byte-arrays generic hashtables
|
USING: alien arrays byte-arrays generic hashtables
|
||||||
hashtables.private io kernel math namespaces parser sequences
|
hashtables.private io kernel math math.order namespaces parser
|
||||||
strings vectors words quotations assocs layouts classes
|
sequences strings vectors words quotations assocs layouts
|
||||||
classes.builtin classes.tuple classes.tuple.private
|
classes classes.builtin classes.tuple classes.tuple.private
|
||||||
kernel.private vocabs vocabs.loader source-files definitions
|
kernel.private vocabs vocabs.loader source-files definitions
|
||||||
slots.deprecated classes.union classes.intersection
|
slots classes.union classes.intersection classes.predicate
|
||||||
compiler.units bootstrap.image.private io.files accessors
|
compiler.units bootstrap.image.private io.files accessors combinators ;
|
||||||
combinators ;
|
|
||||||
IN: bootstrap.primitives
|
IN: bootstrap.primitives
|
||||||
|
|
||||||
"Creating primitives and basic runtime structures..." print flush
|
"Creating primitives and basic runtime structures..." print flush
|
||||||
|
@ -62,15 +61,14 @@ bootstrapping? on
|
||||||
"alien"
|
"alien"
|
||||||
"alien.accessors"
|
"alien.accessors"
|
||||||
"arrays"
|
"arrays"
|
||||||
"bit-arrays"
|
|
||||||
"byte-arrays"
|
"byte-arrays"
|
||||||
"byte-vectors"
|
"byte-vectors"
|
||||||
"classes.private"
|
"classes.private"
|
||||||
"classes.tuple"
|
"classes.tuple"
|
||||||
"classes.tuple.private"
|
"classes.tuple.private"
|
||||||
|
"classes.predicate"
|
||||||
"compiler.units"
|
"compiler.units"
|
||||||
"continuations.private"
|
"continuations.private"
|
||||||
"float-arrays"
|
|
||||||
"generator"
|
"generator"
|
||||||
"growable"
|
"growable"
|
||||||
"hashtables"
|
"hashtables"
|
||||||
|
@ -105,24 +103,8 @@ bootstrapping? on
|
||||||
} [ create-vocab drop ] each
|
} [ create-vocab drop ] each
|
||||||
|
|
||||||
! Builtin classes
|
! Builtin classes
|
||||||
: lo-tag-eq-quot ( n -- quot )
|
|
||||||
[ \ tag , , \ eq? , ] [ ] make ;
|
|
||||||
|
|
||||||
: hi-tag-eq-quot ( n -- quot )
|
|
||||||
[
|
|
||||||
[ dup tag ] % \ hi-tag tag-number , \ eq? ,
|
|
||||||
[ [ hi-tag ] % , \ eq? , ] [ ] make ,
|
|
||||||
[ drop f ] ,
|
|
||||||
\ if ,
|
|
||||||
] [ ] make ;
|
|
||||||
|
|
||||||
: builtin-predicate-quot ( class -- quot )
|
|
||||||
"type" word-prop
|
|
||||||
dup tag-mask get <
|
|
||||||
[ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
|
|
||||||
|
|
||||||
: define-builtin-predicate ( class -- )
|
: define-builtin-predicate ( class -- )
|
||||||
dup builtin-predicate-quot define-predicate ;
|
dup class>type [ builtin-instance? ] curry define-predicate ;
|
||||||
|
|
||||||
: lookup-type-number ( word -- n )
|
: lookup-type-number ( word -- n )
|
||||||
global [ target-word ] bind type-number ;
|
global [ target-word ] bind type-number ;
|
||||||
|
@ -133,9 +115,12 @@ bootstrapping? on
|
||||||
[ f f f builtin-class define-class ]
|
[ f f f builtin-class define-class ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
: define-builtin-slots ( symbol slotspec -- )
|
: prepare-slots ( slots -- slots' )
|
||||||
[ drop ] [ 1 simple-slots ] 2bi
|
[ [ dup pair? [ first2 create ] when ] map ] map ;
|
||||||
[ "slots" set-word-prop ] [ define-slots ] 2bi ;
|
|
||||||
|
: define-builtin-slots ( class slots -- )
|
||||||
|
prepare-slots 1 make-slots
|
||||||
|
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
|
||||||
|
|
||||||
: define-builtin ( symbol slotspec -- )
|
: define-builtin ( symbol slotspec -- )
|
||||||
>r [ define-builtin-predicate ] keep
|
>r [ define-builtin-predicate ] keep
|
||||||
|
@ -150,10 +135,8 @@ bootstrapping? on
|
||||||
"f" "syntax" lookup register-builtin
|
"f" "syntax" lookup register-builtin
|
||||||
"array" "arrays" create register-builtin
|
"array" "arrays" create register-builtin
|
||||||
"wrapper" "kernel" create register-builtin
|
"wrapper" "kernel" create register-builtin
|
||||||
"float-array" "float-arrays" create register-builtin
|
|
||||||
"callstack" "kernel" create register-builtin
|
"callstack" "kernel" create register-builtin
|
||||||
"string" "strings" create register-builtin
|
"string" "strings" create register-builtin
|
||||||
"bit-array" "bit-arrays" create register-builtin
|
|
||||||
"quotation" "quotations" create register-builtin
|
"quotation" "quotations" create register-builtin
|
||||||
"dll" "alien" create register-builtin
|
"dll" "alien" create register-builtin
|
||||||
"alien" "alien" create register-builtin
|
"alien" "alien" create register-builtin
|
||||||
|
@ -161,6 +144,46 @@ bootstrapping? on
|
||||||
"byte-array" "byte-arrays" create register-builtin
|
"byte-array" "byte-arrays" create register-builtin
|
||||||
"tuple-layout" "classes.tuple.private" create register-builtin
|
"tuple-layout" "classes.tuple.private" create register-builtin
|
||||||
|
|
||||||
|
! For predicate classes
|
||||||
|
"predicate-instance?" "classes.predicate" create drop
|
||||||
|
|
||||||
|
! We need this before defining c-ptr below
|
||||||
|
"f" "syntax" lookup { } define-builtin
|
||||||
|
|
||||||
|
"f" "syntax" create [ not ] "predicate" set-word-prop
|
||||||
|
"f?" "syntax" vocab-words delete-at
|
||||||
|
|
||||||
|
! Some unions
|
||||||
|
"integer" "math" create
|
||||||
|
"fixnum" "math" lookup
|
||||||
|
"bignum" "math" lookup
|
||||||
|
2array
|
||||||
|
define-union-class
|
||||||
|
|
||||||
|
"rational" "math" create
|
||||||
|
"integer" "math" lookup
|
||||||
|
"ratio" "math" lookup
|
||||||
|
2array
|
||||||
|
define-union-class
|
||||||
|
|
||||||
|
"real" "math" create
|
||||||
|
"rational" "math" lookup
|
||||||
|
"float" "math" lookup
|
||||||
|
2array
|
||||||
|
define-union-class
|
||||||
|
|
||||||
|
"c-ptr" "alien" create [
|
||||||
|
"alien" "alien" lookup ,
|
||||||
|
"f" "syntax" lookup ,
|
||||||
|
"byte-array" "byte-arrays" lookup ,
|
||||||
|
] { } make define-union-class
|
||||||
|
|
||||||
|
! A predicate class used for declarations
|
||||||
|
"array-capacity" "sequences.private" create
|
||||||
|
"fixnum" "math" lookup
|
||||||
|
0 bootstrap-max-array-capacity [ between? ] 2curry
|
||||||
|
define-predicate-class
|
||||||
|
|
||||||
! Catch-all class for providing a default method.
|
! Catch-all class for providing a default method.
|
||||||
"object" "kernel" create
|
"object" "kernel" create
|
||||||
[ f f { } intersection-class define-class ]
|
[ f f { } intersection-class define-class ]
|
||||||
|
@ -188,184 +211,63 @@ bi
|
||||||
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
|
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
|
||||||
|
|
||||||
"ratio" "math" create {
|
"ratio" "math" create {
|
||||||
{
|
{ "numerator" { "integer" "math" } read-only }
|
||||||
{ "integer" "math" }
|
{ "denominator" { "integer" "math" } read-only }
|
||||||
"numerator"
|
|
||||||
{ "numerator" "math" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "integer" "math" }
|
|
||||||
"denominator"
|
|
||||||
{ "denominator" "math" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"float" "math" create { } define-builtin
|
"float" "math" create { } define-builtin
|
||||||
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
|
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
|
||||||
|
|
||||||
"complex" "math" create {
|
"complex" "math" create {
|
||||||
{
|
{ "real" { "real" "math" } read-only }
|
||||||
{ "real" "math" }
|
{ "imaginary" { "real" "math" } read-only }
|
||||||
"real-part"
|
|
||||||
{ "real-part" "math" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "real" "math" }
|
|
||||||
"imaginary-part"
|
|
||||||
{ "imaginary-part" "math" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"f" "syntax" lookup { } define-builtin
|
|
||||||
|
|
||||||
"array" "arrays" create { } define-builtin
|
"array" "arrays" create { } define-builtin
|
||||||
|
|
||||||
"wrapper" "kernel" create {
|
"wrapper" "kernel" create {
|
||||||
{
|
{ "wrapped" read-only }
|
||||||
{ "object" "kernel" }
|
|
||||||
"wrapped"
|
|
||||||
{ "wrapped" "kernel" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"string" "strings" create {
|
"string" "strings" create {
|
||||||
{
|
{ "length" { "array-capacity" "sequences.private" } read-only }
|
||||||
{ "array-capacity" "sequences.private" }
|
"aux"
|
||||||
"length"
|
|
||||||
{ "length" "sequences" }
|
|
||||||
f
|
|
||||||
} {
|
|
||||||
{ "object" "kernel" }
|
|
||||||
"aux"
|
|
||||||
{ "string-aux" "strings.private" }
|
|
||||||
{ "set-string-aux" "strings.private" }
|
|
||||||
}
|
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"quotation" "quotations" create {
|
"quotation" "quotations" create {
|
||||||
{
|
{ "array" { "array" "arrays" } read-only }
|
||||||
{ "object" "kernel" }
|
{ "compiled" read-only }
|
||||||
"array"
|
|
||||||
{ "quotation-array" "quotations.private" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "object" "kernel" }
|
|
||||||
"compiled?"
|
|
||||||
{ "quotation-compiled?" "quotations" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"dll" "alien" create {
|
"dll" "alien" create {
|
||||||
{
|
{ "path" { "byte-array" "byte-arrays" } read-only }
|
||||||
{ "byte-array" "byte-arrays" }
|
} define-builtin
|
||||||
"path"
|
|
||||||
{ "(dll-path)" "alien" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
}
|
|
||||||
define-builtin
|
|
||||||
|
|
||||||
"alien" "alien" create {
|
"alien" "alien" create {
|
||||||
{
|
{ "underlying" { "c-ptr" "alien" } read-only }
|
||||||
{ "c-ptr" "alien" }
|
"expired"
|
||||||
"alien"
|
} define-builtin
|
||||||
{ "underlying-alien" "alien" }
|
|
||||||
f
|
|
||||||
} {
|
|
||||||
{ "object" "kernel" }
|
|
||||||
"expired?"
|
|
||||||
{ "expired?" "alien" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
}
|
|
||||||
define-builtin
|
|
||||||
|
|
||||||
"word" "words" create {
|
"word" "words" create {
|
||||||
f
|
{ "hashcode" { "fixnum" "math" } }
|
||||||
{
|
"name"
|
||||||
{ "object" "kernel" }
|
"vocabulary"
|
||||||
"name"
|
{ "def" { "quotation" "quotations" } initial: [ ] }
|
||||||
{ "word-name" "words" }
|
"props"
|
||||||
{ "set-word-name" "words" }
|
{ "compiled" read-only }
|
||||||
}
|
{ "counter" { "fixnum" "math" } }
|
||||||
{
|
|
||||||
{ "object" "kernel" }
|
|
||||||
"vocabulary"
|
|
||||||
{ "word-vocabulary" "words" }
|
|
||||||
{ "set-word-vocabulary" "words" }
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "quotation" "quotations" }
|
|
||||||
"def"
|
|
||||||
{ "word-def" "words" }
|
|
||||||
{ "set-word-def" "words.private" }
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "object" "kernel" }
|
|
||||||
"props"
|
|
||||||
{ "word-props" "words" }
|
|
||||||
{ "set-word-props" "words" }
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "object" "kernel" }
|
|
||||||
"compiled?"
|
|
||||||
{ "compiled?" "words" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "fixnum" "math" }
|
|
||||||
"counter"
|
|
||||||
{ "profile-counter" "tools.profiler.private" }
|
|
||||||
{ "set-profile-counter" "tools.profiler.private" }
|
|
||||||
}
|
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"byte-array" "byte-arrays" create { } define-builtin
|
"byte-array" "byte-arrays" create { } define-builtin
|
||||||
|
|
||||||
"bit-array" "bit-arrays" create { } define-builtin
|
|
||||||
|
|
||||||
"float-array" "float-arrays" create { } define-builtin
|
|
||||||
|
|
||||||
"callstack" "kernel" create { } define-builtin
|
"callstack" "kernel" create { } define-builtin
|
||||||
|
|
||||||
"tuple-layout" "classes.tuple.private" create {
|
"tuple-layout" "classes.tuple.private" create {
|
||||||
{
|
{ "hashcode" { "fixnum" "math" } read-only }
|
||||||
{ "fixnum" "math" }
|
{ "class" { "word" "words" } initial: t read-only }
|
||||||
"hashcode"
|
{ "size" { "fixnum" "math" } read-only }
|
||||||
{ "layout-hashcode" "classes.tuple.private" }
|
{ "superclasses" { "array" "arrays" } initial: { } read-only }
|
||||||
f
|
{ "echelon" { "fixnum" "math" } read-only }
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "word" "words" }
|
|
||||||
"class"
|
|
||||||
{ "layout-class" "classes.tuple.private" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "fixnum" "math" }
|
|
||||||
"size"
|
|
||||||
{ "layout-size" "classes.tuple.private" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "array" "arrays" }
|
|
||||||
"superclasses"
|
|
||||||
{ "layout-superclasses" "classes.tuple.private" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "fixnum" "math" }
|
|
||||||
"echelon"
|
|
||||||
{ "layout-echelon" "classes.tuple.private" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"tuple" "kernel" create {
|
"tuple" "kernel" create {
|
||||||
|
@ -373,24 +275,14 @@ define-builtin
|
||||||
[ { "delegate" } "slot-names" set-word-prop ]
|
[ { "delegate" } "slot-names" set-word-prop ]
|
||||||
[ define-tuple-layout ]
|
[ define-tuple-layout ]
|
||||||
[
|
[
|
||||||
{
|
{ "delegate" }
|
||||||
{
|
|
||||||
{ "object" "kernel" }
|
|
||||||
"delegate"
|
|
||||||
{ "delegate" "kernel" }
|
|
||||||
{ "set-delegate" "kernel" }
|
|
||||||
}
|
|
||||||
}
|
|
||||||
[ drop ] [ generate-tuple-slots ] 2bi
|
[ drop ] [ generate-tuple-slots ] 2bi
|
||||||
[ "slots" set-word-prop ]
|
[ "slots" set-word-prop ]
|
||||||
[ define-slots ]
|
[ define-accessors ]
|
||||||
2bi
|
2bi
|
||||||
]
|
]
|
||||||
} cleave
|
} cleave
|
||||||
|
|
||||||
"f" "syntax" create [ not ] "predicate" set-word-prop
|
|
||||||
"f?" "syntax" vocab-words delete-at
|
|
||||||
|
|
||||||
! Create special tombstone values
|
! Create special tombstone values
|
||||||
"tombstone" "hashtables.private" create
|
"tombstone" "hashtables.private" create
|
||||||
tuple
|
tuple
|
||||||
|
@ -405,90 +297,12 @@ tuple
|
||||||
2array >tuple 1quotation define-inline
|
2array >tuple 1quotation define-inline
|
||||||
|
|
||||||
! Some tuple classes
|
! 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
|
"curry" "kernel" create
|
||||||
tuple
|
tuple
|
||||||
{
|
{
|
||||||
{
|
{ "obj" read-only }
|
||||||
{ "object" "kernel" }
|
{ "quot" read-only }
|
||||||
"obj"
|
} prepare-slots define-tuple-class
|
||||||
{ "curry-obj" "kernel" }
|
|
||||||
f
|
|
||||||
} {
|
|
||||||
{ "object" "kernel" }
|
|
||||||
"quot"
|
|
||||||
{ "curry-quot" "kernel" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
} define-tuple-class
|
|
||||||
|
|
||||||
"curry" "kernel" lookup
|
"curry" "kernel" lookup
|
||||||
[ f "inline" set-word-prop ]
|
[ f "inline" set-word-prop ]
|
||||||
|
@ -499,18 +313,9 @@ tuple
|
||||||
"compose" "kernel" create
|
"compose" "kernel" create
|
||||||
tuple
|
tuple
|
||||||
{
|
{
|
||||||
{
|
{ "first" read-only }
|
||||||
{ "object" "kernel" }
|
{ "second" read-only }
|
||||||
"first"
|
} prepare-slots define-tuple-class
|
||||||
{ "compose-first" "kernel" }
|
|
||||||
f
|
|
||||||
} {
|
|
||||||
{ "object" "kernel" }
|
|
||||||
"second"
|
|
||||||
{ "compose-second" "kernel" }
|
|
||||||
f
|
|
||||||
}
|
|
||||||
} define-tuple-class
|
|
||||||
|
|
||||||
"compose" "kernel" lookup
|
"compose" "kernel" lookup
|
||||||
[ f "inline" set-word-prop ]
|
[ f "inline" set-word-prop ]
|
||||||
|
@ -634,7 +439,6 @@ tuple
|
||||||
{ "dlsym" "alien" }
|
{ "dlsym" "alien" }
|
||||||
{ "dlclose" "alien" }
|
{ "dlclose" "alien" }
|
||||||
{ "<byte-array>" "byte-arrays" }
|
{ "<byte-array>" "byte-arrays" }
|
||||||
{ "<bit-array>" "bit-arrays" }
|
|
||||||
{ "<displaced-alien>" "alien" }
|
{ "<displaced-alien>" "alien" }
|
||||||
{ "alien-signed-cell" "alien.accessors" }
|
{ "alien-signed-cell" "alien.accessors" }
|
||||||
{ "set-alien-signed-cell" "alien.accessors" }
|
{ "set-alien-signed-cell" "alien.accessors" }
|
||||||
|
@ -693,7 +497,6 @@ tuple
|
||||||
{ "profiling" "tools.profiler.private" }
|
{ "profiling" "tools.profiler.private" }
|
||||||
{ "become" "kernel.private" }
|
{ "become" "kernel.private" }
|
||||||
{ "(sleep)" "threads.private" }
|
{ "(sleep)" "threads.private" }
|
||||||
{ "<float-array>" "float-arrays" }
|
|
||||||
{ "<tuple-boa>" "classes.tuple.private" }
|
{ "<tuple-boa>" "classes.tuple.private" }
|
||||||
{ "callstack>array" "kernel" }
|
{ "callstack>array" "kernel" }
|
||||||
{ "innermost-frame-quot" "kernel.private" }
|
{ "innermost-frame-quot" "kernel.private" }
|
||||||
|
@ -705,8 +508,6 @@ tuple
|
||||||
{ "unset-os-env" "system" }
|
{ "unset-os-env" "system" }
|
||||||
{ "(set-os-envs)" "system.private" }
|
{ "(set-os-envs)" "system.private" }
|
||||||
{ "resize-byte-array" "byte-arrays" }
|
{ "resize-byte-array" "byte-arrays" }
|
||||||
{ "resize-bit-array" "bit-arrays" }
|
|
||||||
{ "resize-float-array" "float-arrays" }
|
|
||||||
{ "dll-valid?" "alien" }
|
{ "dll-valid?" "alien" }
|
||||||
{ "unimplemented" "kernel.private" }
|
{ "unimplemented" "kernel.private" }
|
||||||
{ "gc-reset" "memory" }
|
{ "gc-reset" "memory" }
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
kernel.private math memory continuations kernel io.files
|
||||||
io.backend system parser vocabs sequences prettyprint
|
io.backend system parser vocabs sequences prettyprint
|
||||||
vocabs.loader combinators splitting source-files strings
|
vocabs.loader combinators splitting source-files strings
|
||||||
|
@ -36,7 +36,7 @@ SYMBOL: bootstrap-time
|
||||||
"Bootstrap completed in " write number>string write
|
"Bootstrap completed in " write number>string write
|
||||||
" minutes and " write number>string write " seconds." print
|
" 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
|
[ symbol? ] count-words " symbol words" print
|
||||||
[ ] count-words " words total" print
|
[ ] count-words " words total" print
|
||||||
|
|
||||||
|
|
|
@ -14,7 +14,6 @@ IN: bootstrap.syntax
|
||||||
":"
|
":"
|
||||||
";"
|
";"
|
||||||
"<PRIVATE"
|
"<PRIVATE"
|
||||||
"?{"
|
|
||||||
"BIN:"
|
"BIN:"
|
||||||
"B{"
|
"B{"
|
||||||
"BV{"
|
"BV{"
|
||||||
|
@ -22,7 +21,6 @@ IN: bootstrap.syntax
|
||||||
"CHAR:"
|
"CHAR:"
|
||||||
"DEFER:"
|
"DEFER:"
|
||||||
"ERROR:"
|
"ERROR:"
|
||||||
"F{"
|
|
||||||
"FORGET:"
|
"FORGET:"
|
||||||
"GENERIC#"
|
"GENERIC#"
|
||||||
"GENERIC:"
|
"GENERIC:"
|
||||||
|
@ -45,6 +43,7 @@ IN: bootstrap.syntax
|
||||||
"SINGLETON:"
|
"SINGLETON:"
|
||||||
"SYMBOL:"
|
"SYMBOL:"
|
||||||
"TUPLE:"
|
"TUPLE:"
|
||||||
|
"SLOT:"
|
||||||
"T{"
|
"T{"
|
||||||
"UNION:"
|
"UNION:"
|
||||||
"INTERSECTION:"
|
"INTERSECTION:"
|
||||||
|
@ -68,6 +67,8 @@ IN: bootstrap.syntax
|
||||||
"<<"
|
"<<"
|
||||||
">>"
|
">>"
|
||||||
"call-next-method"
|
"call-next-method"
|
||||||
|
"initial:"
|
||||||
|
"read-only"
|
||||||
} [ "syntax" create drop ] each
|
} [ "syntax" create drop ] each
|
||||||
|
|
||||||
"t" "syntax" lookup define-symbol
|
"t" "syntax" lookup define-symbol
|
||||||
|
|
|
@ -30,11 +30,6 @@ HELP: >byte-vector
|
||||||
{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }
|
{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }
|
||||||
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
|
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
|
||||||
|
|
||||||
HELP: byte-array>vector
|
|
||||||
{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }
|
|
||||||
{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }
|
|
||||||
{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;
|
|
||||||
|
|
||||||
HELP: BV{
|
HELP: BV{
|
||||||
{ $syntax "BV{ elements... }" }
|
{ $syntax "BV{ elements... }" }
|
||||||
{ $values { "elements" "a list of bytes" } }
|
{ $values { "elements" "a list of bytes" } }
|
||||||
|
|
|
@ -4,15 +4,12 @@ USING: arrays kernel kernel.private math sequences
|
||||||
sequences.private growable byte-arrays ;
|
sequences.private growable byte-arrays ;
|
||||||
IN: byte-vectors
|
IN: byte-vectors
|
||||||
|
|
||||||
<PRIVATE
|
TUPLE: byte-vector
|
||||||
|
{ underlying byte-array }
|
||||||
: byte-array>vector ( byte-array length -- byte-vector )
|
{ length array-capacity } ;
|
||||||
byte-vector boa ; inline
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: <byte-vector> ( n -- byte-vector )
|
: <byte-vector> ( n -- byte-vector )
|
||||||
<byte-array> 0 byte-array>vector ; inline
|
<byte-array> 0 byte-vector boa ; inline
|
||||||
|
|
||||||
: >byte-vector ( seq -- byte-vector )
|
: >byte-vector ( seq -- byte-vector )
|
||||||
T{ byte-vector f B{ } 0 } clone-like ;
|
T{ byte-vector f B{ } 0 } clone-like ;
|
||||||
|
@ -20,11 +17,11 @@ PRIVATE>
|
||||||
M: byte-vector like
|
M: byte-vector like
|
||||||
drop dup byte-vector? [
|
drop dup byte-vector? [
|
||||||
dup byte-array?
|
dup byte-array?
|
||||||
[ dup length byte-array>vector ] [ >byte-vector ] if
|
[ dup length byte-vector boa ] [ >byte-vector ] if
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
M: byte-vector new-sequence
|
M: byte-vector new-sequence
|
||||||
drop [ <byte-array> ] keep >fixnum byte-array>vector ;
|
drop [ <byte-array> ] [ >fixnum ] bi byte-vector boa ;
|
||||||
|
|
||||||
M: byte-vector equal?
|
M: byte-vector equal?
|
||||||
over byte-vector? [ sequence= ] [ 2drop f ] if ;
|
over byte-vector? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
|
@ -214,7 +214,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
|
||||||
[ "Topological sort failed" throw ] unless* ;
|
[ "Topological sort failed" throw ] unless* ;
|
||||||
|
|
||||||
: sort-classes ( seq -- newseq )
|
: sort-classes ( seq -- newseq )
|
||||||
[ [ word-name ] compare ] sort >vector
|
[ [ name>> ] compare ] sort >vector
|
||||||
[ dup empty? not ]
|
[ dup empty? not ]
|
||||||
[ dup largest-class >r over delete-nth r> ]
|
[ dup largest-class >r over delete-nth r> ]
|
||||||
[ ] unfold nip ;
|
[ ] unfold nip ;
|
||||||
|
|
|
@ -0,0 +1,10 @@
|
||||||
|
IN: classes.builtin.tests
|
||||||
|
USING: tools.test words sequences kernel memory accessors ;
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
[ word? ] instances
|
||||||
|
[
|
||||||
|
[ name>> "f?" = ]
|
||||||
|
[ vocabulary>> "syntax" = ] bi and
|
||||||
|
] contains?
|
||||||
|
] unit-test
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: classes words kernel kernel.private namespaces
|
USING: classes words kernel kernel.private namespaces
|
||||||
sequences ;
|
sequences math math.private ;
|
||||||
IN: classes.builtin
|
IN: classes.builtin
|
||||||
|
|
||||||
SYMBOL: builtins
|
SYMBOL: builtins
|
||||||
|
@ -11,6 +11,8 @@ PREDICATE: builtin-class < class
|
||||||
|
|
||||||
: type>class ( n -- class ) builtins get-global nth ;
|
: type>class ( n -- class ) builtins get-global nth ;
|
||||||
|
|
||||||
|
: class>type ( class -- n ) "type" word-prop ; foldable
|
||||||
|
|
||||||
: bootstrap-type>class ( n -- class ) builtins get nth ;
|
: bootstrap-type>class ( n -- class ) builtins get nth ;
|
||||||
|
|
||||||
M: hi-tag class hi-tag type>class ;
|
M: hi-tag class hi-tag type>class ;
|
||||||
|
@ -18,3 +20,14 @@ M: hi-tag class hi-tag type>class ;
|
||||||
M: object class tag type>class ;
|
M: object class tag type>class ;
|
||||||
|
|
||||||
M: builtin-class rank-class drop 0 ;
|
M: builtin-class rank-class drop 0 ;
|
||||||
|
|
||||||
|
: builtin-instance? ( object n -- ? )
|
||||||
|
#! 7 == tag-mask get
|
||||||
|
#! 3 == hi-tag tag-number
|
||||||
|
dup 7 fixnum<= [ swap tag eq? ] [
|
||||||
|
swap dup tag 3 eq?
|
||||||
|
[ hi-tag eq? ] [ 2drop f ] if
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
M: builtin-class instance?
|
||||||
|
class>type builtin-instance? ;
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: help.markup help.syntax kernel kernel.private
|
USING: help.markup help.syntax kernel kernel.private
|
||||||
namespaces sequences words arrays layouts help effects math
|
namespaces sequences words arrays layouts effects math
|
||||||
layouts classes.private classes.union classes.mixin
|
layouts classes.private classes.union classes.mixin
|
||||||
classes.predicate quotations ;
|
classes.predicate quotations ;
|
||||||
IN: classes
|
IN: classes
|
||||||
|
@ -32,6 +32,8 @@ $nl
|
||||||
{ $subsection class }
|
{ $subsection class }
|
||||||
"Testing if an object is an instance of a class:"
|
"Testing if an object is an instance of a class:"
|
||||||
{ $subsection instance? }
|
{ $subsection instance? }
|
||||||
|
"Class predicates can be used to test instances directly:"
|
||||||
|
{ $subsection "class-predicates" }
|
||||||
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
|
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
|
||||||
{ $subsection object }
|
{ $subsection object }
|
||||||
{ $subsection null }
|
{ $subsection null }
|
||||||
|
|
|
@ -6,154 +6,6 @@ classes.algebra vectors definitions source-files
|
||||||
compiler.units kernel.private sorting vocabs ;
|
compiler.units kernel.private sorting vocabs ;
|
||||||
IN: classes.tests
|
IN: classes.tests
|
||||||
|
|
||||||
! DEFER: bah
|
|
||||||
! FORGET: bah
|
|
||||||
UNION: bah fixnum alien ;
|
|
||||||
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
|
|
||||||
|
|
||||||
! Test redefinition of classes
|
|
||||||
UNION: union-1 fixnum float ;
|
|
||||||
|
|
||||||
GENERIC: generic-update-test ( x -- y )
|
|
||||||
|
|
||||||
M: union-1 generic-update-test drop "union-1" ;
|
|
||||||
|
|
||||||
[ f ] [ bignum union-1 class<= ] unit-test
|
|
||||||
[ t ] [ union-1 number class<= ] unit-test
|
|
||||||
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
|
|
||||||
|
|
||||||
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
|
|
||||||
|
|
||||||
[ t ] [ bignum union-1 class<= ] unit-test
|
|
||||||
[ f ] [ union-1 number class<= ] unit-test
|
|
||||||
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
|
|
||||||
|
|
||||||
"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
|
|
||||||
|
|
||||||
[ f ] [ union-1 union-class? ] unit-test
|
|
||||||
[ t ] [ union-1 predicate-class? ] unit-test
|
|
||||||
[ "union-1" ] [ 8 generic-update-test ] unit-test
|
|
||||||
[ -7 generic-update-test ] must-fail
|
|
||||||
|
|
||||||
! Test mixins
|
|
||||||
MIXIN: sequence-mixin
|
|
||||||
|
|
||||||
INSTANCE: array sequence-mixin
|
|
||||||
INSTANCE: vector sequence-mixin
|
|
||||||
INSTANCE: slice sequence-mixin
|
|
||||||
|
|
||||||
MIXIN: assoc-mixin
|
|
||||||
|
|
||||||
INSTANCE: hashtable assoc-mixin
|
|
||||||
|
|
||||||
GENERIC: collection-size ( x -- y )
|
|
||||||
|
|
||||||
M: sequence-mixin collection-size length ;
|
|
||||||
|
|
||||||
M: assoc-mixin collection-size assoc-size ;
|
|
||||||
|
|
||||||
[ t ] [ array sequence-mixin class<= ] unit-test
|
|
||||||
[ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
|
|
||||||
[ 3 ] [ { 1 2 3 } collection-size ] unit-test
|
|
||||||
[ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
|
|
||||||
[ t ] [ H{ { 1 2 } { 2 3 } } assoc-mixin? ] unit-test
|
|
||||||
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
|
|
||||||
|
|
||||||
! Test mixing in of new classes after the fact
|
|
||||||
DEFER: mx1
|
|
||||||
FORGET: mx1
|
|
||||||
|
|
||||||
MIXIN: mx1
|
|
||||||
|
|
||||||
INSTANCE: integer mx1
|
|
||||||
|
|
||||||
[ t ] [ integer mx1 class<= ] unit-test
|
|
||||||
[ t ] [ mx1 integer class<= ] unit-test
|
|
||||||
[ t ] [ mx1 number class<= ] unit-test
|
|
||||||
|
|
||||||
"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
|
|
||||||
|
|
||||||
[ t ] [ array mx1 class<= ] unit-test
|
|
||||||
[ f ] [ mx1 number class<= ] unit-test
|
|
||||||
|
|
||||||
[ \ mx1 forget ] with-compilation-unit
|
|
||||||
|
|
||||||
! Empty unions were causing problems
|
|
||||||
GENERIC: empty-union-test ( obj -- obj )
|
|
||||||
|
|
||||||
UNION: empty-union-1 ;
|
|
||||||
|
|
||||||
M: empty-union-1 empty-union-test ;
|
|
||||||
|
|
||||||
UNION: empty-union-2 ;
|
|
||||||
|
|
||||||
M: empty-union-2 empty-union-test ;
|
|
||||||
|
|
||||||
! Redefining a class didn't update containing unions
|
|
||||||
UNION: redefine-bug-1 fixnum ;
|
|
||||||
|
|
||||||
UNION: redefine-bug-2 redefine-bug-1 quotation ;
|
|
||||||
|
|
||||||
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
|
|
||||||
[ t ] [ quotation redefine-bug-2 class<= ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ bignum redefine-bug-1 class<= ] unit-test
|
|
||||||
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
|
|
||||||
[ t ] [ bignum redefine-bug-2 class<= ] unit-test
|
|
||||||
|
|
||||||
USE: io.streams.string
|
|
||||||
|
|
||||||
2 [
|
|
||||||
[ "mixin-forget-test" forget-source ] with-compilation-unit
|
|
||||||
|
|
||||||
[ ] [
|
|
||||||
{
|
|
||||||
"USING: sequences ;"
|
|
||||||
"IN: classes.tests"
|
|
||||||
"MIXIN: mixin-forget-test"
|
|
||||||
"INSTANCE: sequence mixin-forget-test"
|
|
||||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
|
||||||
"M: mixin-forget-test mixin-forget-test-g ;"
|
|
||||||
} "\n" join <string-reader> "mixin-forget-test"
|
|
||||||
parse-stream drop
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
|
|
||||||
[ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
|
|
||||||
|
|
||||||
[ ] [
|
|
||||||
{
|
|
||||||
"USING: hashtables ;"
|
|
||||||
"IN: classes.tests"
|
|
||||||
"MIXIN: mixin-forget-test"
|
|
||||||
"INSTANCE: hashtable mixin-forget-test"
|
|
||||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
|
||||||
"M: mixin-forget-test mixin-forget-test-g ;"
|
|
||||||
} "\n" join <string-reader> "mixin-forget-test"
|
|
||||||
parse-stream drop
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
|
|
||||||
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
|
|
||||||
] times
|
|
||||||
|
|
||||||
! Method flattening interfered with mixin update
|
|
||||||
MIXIN: flat-mx-1
|
|
||||||
TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
|
|
||||||
TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
|
|
||||||
TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
|
|
||||||
TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
|
|
||||||
MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
|
|
||||||
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
|
||||||
|
|
||||||
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
|
|
||||||
|
|
||||||
! Test generic see and parsing
|
|
||||||
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
|
|
||||||
[ [ \ bah see ] with-string-writer ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ 3 object instance? ] unit-test
|
[ t ] [ 3 object instance? ] unit-test
|
||||||
[ t ] [ 3 fixnum instance? ] unit-test
|
[ t ] [ 3 fixnum instance? ] unit-test
|
||||||
[ f ] [ 3 float instance? ] unit-test
|
[ f ] [ 3 float instance? ] unit-test
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
slots.private namespaces sequences strings words vectors math
|
||||||
quotations combinators sorting effects graphs vocabs sets ;
|
quotations combinators sorting effects graphs vocabs sets ;
|
||||||
IN: classes
|
IN: classes
|
||||||
|
@ -38,7 +38,7 @@ PREDICATE: tuple-class < class
|
||||||
: classes ( -- seq ) implementors-map get keys ;
|
: classes ( -- seq ) implementors-map get keys ;
|
||||||
|
|
||||||
: predicate-word ( word -- predicate )
|
: predicate-word ( word -- predicate )
|
||||||
[ word-name "?" append ] keep word-vocabulary create ;
|
[ name>> "?" append ] [ vocabulary>> ] bi create ;
|
||||||
|
|
||||||
PREDICATE: predicate < word "predicating" word-prop >boolean ;
|
PREDICATE: predicate < word "predicating" word-prop >boolean ;
|
||||||
|
|
||||||
|
@ -72,6 +72,7 @@ M: class reset-class
|
||||||
"superclass"
|
"superclass"
|
||||||
"members"
|
"members"
|
||||||
"participants"
|
"participants"
|
||||||
|
"predicate"
|
||||||
} reset-props ;
|
} reset-props ;
|
||||||
|
|
||||||
M: word reset-class drop ;
|
M: word reset-class drop ;
|
||||||
|
@ -87,8 +88,9 @@ GENERIC: implementors ( class/classes -- seq )
|
||||||
tri
|
tri
|
||||||
] { } make ;
|
] { } make ;
|
||||||
|
|
||||||
: class-usages ( class -- seq )
|
: class-usage ( class -- seq ) update-map get at ;
|
||||||
[ update-map get at ] closure keys ;
|
|
||||||
|
: class-usages ( class -- seq ) [ class-usage ] closure keys ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
@ -123,8 +125,8 @@ M: sequence implementors [ implementors ] gather ;
|
||||||
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
|
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
|
||||||
dup reset-class
|
dup reset-class
|
||||||
dup deferred? [ dup define-symbol ] when
|
dup deferred? [ dup define-symbol ] when
|
||||||
dup word-props
|
dup props>>
|
||||||
r> assoc-union over set-word-props
|
r> assoc-union >>props
|
||||||
dup predicate-word
|
dup predicate-word
|
||||||
[ 1quotation "predicate" set-word-prop ]
|
[ 1quotation "predicate" set-word-prop ]
|
||||||
[ swap "predicating" set-word-prop ]
|
[ swap "predicating" set-word-prop ]
|
||||||
|
@ -163,21 +165,24 @@ GENERIC: update-methods ( class seq -- )
|
||||||
: forget-methods ( class -- )
|
: forget-methods ( class -- )
|
||||||
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
|
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
|
||||||
|
|
||||||
|
GENERIC: class-forgotten ( use class -- )
|
||||||
|
|
||||||
: forget-class ( class -- )
|
: forget-class ( class -- )
|
||||||
class-usages [
|
{
|
||||||
{
|
[ dup class-usage keys [ class-forgotten ] with each ]
|
||||||
[ forget-predicate ]
|
[ forget-predicate ]
|
||||||
[ forget-methods ]
|
[ forget-methods ]
|
||||||
[ implementors-map- ]
|
[ implementors-map- ]
|
||||||
[ update-map- ]
|
[ update-map- ]
|
||||||
[ reset-class ]
|
[ reset-class ]
|
||||||
} cleave
|
} cleave ;
|
||||||
] each ;
|
|
||||||
|
M: class class-forgotten
|
||||||
|
nip forget-class ;
|
||||||
|
|
||||||
M: class forget* ( class -- )
|
M: class forget* ( class -- )
|
||||||
[ forget-class ] [ call-next-method ] bi ;
|
[ call-next-method ] [ forget-class ] bi ;
|
||||||
|
|
||||||
GENERIC: class ( object -- class )
|
GENERIC: class ( object -- class )
|
||||||
|
|
||||||
: instance? ( obj class -- ? )
|
GENERIC: instance? ( object class -- ? )
|
||||||
"predicate" word-prop call ;
|
|
||||||
|
|
|
@ -28,3 +28,6 @@ M: intersection-class update-class define-intersection-predicate ;
|
||||||
2bi ;
|
2bi ;
|
||||||
|
|
||||||
M: intersection-class rank-class drop 2 ;
|
M: intersection-class rank-class drop 2 ;
|
||||||
|
|
||||||
|
M: intersection-class instance?
|
||||||
|
"participants" word-prop [ instance? ] with all? ;
|
||||||
|
|
|
@ -0,0 +1,107 @@
|
||||||
|
USING: alien arrays definitions generic assocs hashtables io
|
||||||
|
kernel math namespaces parser prettyprint sequences strings
|
||||||
|
tools.test vectors words quotations classes
|
||||||
|
classes.private classes.union classes.mixin classes.predicate
|
||||||
|
classes.algebra vectors definitions source-files
|
||||||
|
compiler.units kernel.private sorting vocabs ;
|
||||||
|
IN: classes.mixin.tests
|
||||||
|
|
||||||
|
! Test mixins
|
||||||
|
MIXIN: sequence-mixin
|
||||||
|
|
||||||
|
INSTANCE: array sequence-mixin
|
||||||
|
INSTANCE: vector sequence-mixin
|
||||||
|
INSTANCE: slice sequence-mixin
|
||||||
|
|
||||||
|
MIXIN: assoc-mixin
|
||||||
|
|
||||||
|
INSTANCE: hashtable assoc-mixin
|
||||||
|
|
||||||
|
GENERIC: collection-size ( x -- y )
|
||||||
|
|
||||||
|
M: sequence-mixin collection-size length ;
|
||||||
|
|
||||||
|
M: assoc-mixin collection-size assoc-size ;
|
||||||
|
|
||||||
|
[ t ] [ array sequence-mixin class<= ] unit-test
|
||||||
|
[ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
|
||||||
|
[ 3 ] [ { 1 2 3 } collection-size ] unit-test
|
||||||
|
[ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
|
||||||
|
[ t ] [ H{ { 1 2 } { 2 3 } } assoc-mixin? ] unit-test
|
||||||
|
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
|
||||||
|
|
||||||
|
! Test mixing in of new classes after the fact
|
||||||
|
DEFER: mx1
|
||||||
|
FORGET: mx1
|
||||||
|
|
||||||
|
MIXIN: mx1
|
||||||
|
|
||||||
|
INSTANCE: integer mx1
|
||||||
|
|
||||||
|
[ t ] [ integer mx1 class<= ] unit-test
|
||||||
|
[ t ] [ mx1 integer class<= ] unit-test
|
||||||
|
[ t ] [ mx1 number class<= ] unit-test
|
||||||
|
|
||||||
|
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval
|
||||||
|
|
||||||
|
[ t ] [ array mx1 class<= ] unit-test
|
||||||
|
[ f ] [ mx1 number class<= ] unit-test
|
||||||
|
|
||||||
|
[ \ mx1 forget ] with-compilation-unit
|
||||||
|
|
||||||
|
USE: io.streams.string
|
||||||
|
|
||||||
|
2 [
|
||||||
|
[ "mixin-forget-test" forget-source ] with-compilation-unit
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
{
|
||||||
|
"USING: sequences ;"
|
||||||
|
"IN: classes.mixin.tests"
|
||||||
|
"MIXIN: mixin-forget-test"
|
||||||
|
"INSTANCE: sequence mixin-forget-test"
|
||||||
|
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||||
|
"M: mixin-forget-test mixin-forget-test-g ;"
|
||||||
|
} "\n" join <string-reader> "mixin-forget-test"
|
||||||
|
parse-stream drop
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ { } ] [ { } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] unit-test
|
||||||
|
[ H{ } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] must-fail
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
{
|
||||||
|
"USING: hashtables ;"
|
||||||
|
"IN: classes.mixin.tests"
|
||||||
|
"MIXIN: mixin-forget-test"
|
||||||
|
"INSTANCE: hashtable mixin-forget-test"
|
||||||
|
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||||
|
"M: mixin-forget-test mixin-forget-test-g ;"
|
||||||
|
} "\n" join <string-reader> "mixin-forget-test"
|
||||||
|
parse-stream drop
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ { } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] must-fail
|
||||||
|
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] unit-test
|
||||||
|
] times
|
||||||
|
|
||||||
|
! Method flattening interfered with mixin update
|
||||||
|
MIXIN: flat-mx-1
|
||||||
|
TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
|
||||||
|
TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
|
||||||
|
TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
|
||||||
|
TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
|
||||||
|
MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
|
||||||
|
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
||||||
|
|
||||||
|
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
|
||||||
|
|
||||||
|
! Too eager with reset-class
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.mixin.tests MIXIN: blah SINGLETON: boo INSTANCE: boo blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
|
|
@ -65,6 +65,8 @@ TUPLE: check-mixin-class mixin ;
|
||||||
update-classes
|
update-classes
|
||||||
] [ 2drop ] if-mixin-member? ;
|
] [ 2drop ] if-mixin-member? ;
|
||||||
|
|
||||||
|
M: mixin-class class-forgotten remove-mixin-instance ;
|
||||||
|
|
||||||
! Definition protocol implementation ensures that removing an
|
! Definition protocol implementation ensures that removing an
|
||||||
! INSTANCE: declaration from a source file updates the mixin.
|
! INSTANCE: declaration from a source file updates the mixin.
|
||||||
TUPLE: mixin-instance loc class mixin ;
|
TUPLE: mixin-instance loc class mixin ;
|
||||||
|
@ -81,8 +83,9 @@ M: mixin-instance hashcode*
|
||||||
[ class>> ] [ mixin>> ] bi 2array hashcode* ;
|
[ class>> ] [ mixin>> ] bi 2array hashcode* ;
|
||||||
|
|
||||||
: <mixin-instance> ( class mixin -- definition )
|
: <mixin-instance> ( class mixin -- definition )
|
||||||
{ set-mixin-instance-class set-mixin-instance-mixin }
|
mixin-instance new
|
||||||
mixin-instance construct ;
|
swap >>mixin
|
||||||
|
swap >>class ;
|
||||||
|
|
||||||
M: mixin-instance where mixin-instance-loc ;
|
M: mixin-instance where mixin-instance-loc ;
|
||||||
|
|
||||||
|
|
|
@ -1,11 +1,27 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: classes kernel namespaces words ;
|
USING: classes kernel namespaces words sequences quotations
|
||||||
|
arrays kernel.private assocs combinators ;
|
||||||
IN: classes.predicate
|
IN: classes.predicate
|
||||||
|
|
||||||
PREDICATE: predicate-class < class
|
PREDICATE: predicate-class < class
|
||||||
"metaclass" word-prop predicate-class eq? ;
|
"metaclass" word-prop predicate-class eq? ;
|
||||||
|
|
||||||
|
DEFER: predicate-instance? ( object class -- ? )
|
||||||
|
|
||||||
|
: update-predicate-instance ( -- )
|
||||||
|
\ predicate-instance? bootstrap-word
|
||||||
|
classes [ predicate-class? ] filter [
|
||||||
|
[ literalize ]
|
||||||
|
[
|
||||||
|
[ superclass 1array [ declare ] curry ]
|
||||||
|
[ "predicate-definition" word-prop ]
|
||||||
|
bi compose
|
||||||
|
]
|
||||||
|
bi
|
||||||
|
] { } map>assoc [ case ] curry
|
||||||
|
define ;
|
||||||
|
|
||||||
: predicate-quot ( class -- quot )
|
: predicate-quot ( class -- quot )
|
||||||
[
|
[
|
||||||
\ dup ,
|
\ dup ,
|
||||||
|
@ -21,7 +37,9 @@ PREDICATE: predicate-class < class
|
||||||
[ dup predicate-quot define-predicate ]
|
[ dup predicate-quot define-predicate ]
|
||||||
[ update-classes ]
|
[ update-classes ]
|
||||||
bi
|
bi
|
||||||
] 3tri ;
|
]
|
||||||
|
3tri
|
||||||
|
update-predicate-instance ;
|
||||||
|
|
||||||
M: predicate-class reset-class
|
M: predicate-class reset-class
|
||||||
[ call-next-method ]
|
[ call-next-method ]
|
||||||
|
@ -29,3 +47,7 @@ M: predicate-class reset-class
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
M: predicate-class rank-class drop 1 ;
|
M: predicate-class rank-class drop 1 ;
|
||||||
|
|
||||||
|
M: predicate-class instance?
|
||||||
|
2dup superclass instance?
|
||||||
|
[ predicate-instance? ] [ 2drop f ] if ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: classes.predicate kernel sequences words ;
|
USING: classes classes.predicate kernel sequences words ;
|
||||||
IN: classes.singleton
|
IN: classes.singleton
|
||||||
|
|
||||||
PREDICATE: singleton-class < predicate-class
|
PREDICATE: singleton-class < predicate-class
|
||||||
|
@ -9,3 +9,5 @@ PREDICATE: singleton-class < predicate-class
|
||||||
|
|
||||||
: define-singleton-class ( word -- )
|
: define-singleton-class ( word -- )
|
||||||
\ word over [ eq? ] curry define-predicate-class ;
|
\ word over [ eq? ] curry define-predicate-class ;
|
||||||
|
|
||||||
|
M: singleton-class instance? eq? ;
|
||||||
|
|
|
@ -0,0 +1,67 @@
|
||||||
|
IN: classes.tuple.parser.tests
|
||||||
|
USING: accessors classes.tuple.parser lexer words classes
|
||||||
|
sequences math kernel slots tools.test parser compiler.units ;
|
||||||
|
|
||||||
|
TUPLE: test-1 ;
|
||||||
|
|
||||||
|
[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test
|
||||||
|
|
||||||
|
TUPLE: test-2 < test-1 ;
|
||||||
|
|
||||||
|
[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test
|
||||||
|
[ test-1 ] [ test-2 superclass ] unit-test
|
||||||
|
|
||||||
|
TUPLE: test-3 a ;
|
||||||
|
|
||||||
|
[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test
|
||||||
|
|
||||||
|
[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
|
||||||
|
|
||||||
|
TUPLE: test-4 < test-3 b ;
|
||||||
|
|
||||||
|
[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test
|
||||||
|
|
||||||
|
TUPLE: test-5 { a integer } ;
|
||||||
|
|
||||||
|
[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test
|
||||||
|
|
||||||
|
TUPLE: test-6 < test-5 { b integer } ;
|
||||||
|
|
||||||
|
[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test
|
||||||
|
|
||||||
|
[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test
|
||||||
|
|
||||||
|
TUPLE: test-7 { b integer initial: 3 } ;
|
||||||
|
|
||||||
|
[ 3 ] [ "b" test-7 "slots" word-prop slot-named initial>> ] unit-test
|
||||||
|
|
||||||
|
TUPLE: test-8 { b integer read-only } ;
|
||||||
|
|
||||||
|
[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test
|
||||||
|
|
||||||
|
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
|
||||||
|
[ error>> invalid-slot-name? ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ]
|
||||||
|
[ error>> invalid-slot-name? ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ]
|
||||||
|
[ error>> unexpected-eof? ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ]
|
||||||
|
[ error>> no-initial-value? ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
|
||||||
|
[ error>> bad-initial-value? ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
{ test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 }
|
||||||
|
[ dup class? [ forget-class ] [ drop ] if ] each
|
||||||
|
] with-compilation-unit
|
||||||
|
] unit-test
|
|
@ -1,11 +1,13 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sets namespaces sequences inspector parser
|
USING: accessors kernel sets namespaces sequences summary parser
|
||||||
lexer combinators words classes.parser classes.tuple ;
|
lexer combinators words classes.parser classes.tuple arrays ;
|
||||||
IN: classes.tuple.parser
|
IN: classes.tuple.parser
|
||||||
|
|
||||||
: shadowed-slots ( superclass slots -- shadowed )
|
: shadowed-slots ( superclass slots -- shadowed )
|
||||||
>r all-slot-names r> intersect ;
|
[ all-slots [ name>> ] map ]
|
||||||
|
[ [ dup array? [ first ] when ] map ]
|
||||||
|
bi* intersect ;
|
||||||
|
|
||||||
: check-slot-shadowing ( class superclass slots -- )
|
: check-slot-shadowing ( class superclass slots -- )
|
||||||
shadowed-slots [
|
shadowed-slots [
|
||||||
|
@ -13,7 +15,7 @@ IN: classes.tuple.parser
|
||||||
"Definition of slot ``" %
|
"Definition of slot ``" %
|
||||||
%
|
%
|
||||||
"'' in class ``" %
|
"'' in class ``" %
|
||||||
word-name %
|
name>> %
|
||||||
"'' shadows a superclass slot" %
|
"'' shadows a superclass slot" %
|
||||||
] "" make note.
|
] "" make note.
|
||||||
] with each ;
|
] with each ;
|
||||||
|
@ -24,27 +26,30 @@ M: invalid-slot-name summary
|
||||||
drop
|
drop
|
||||||
"Invalid slot name" ;
|
"Invalid slot name" ;
|
||||||
|
|
||||||
: (parse-tuple-slots) ( -- )
|
: parse-long-slot-name ( -- )
|
||||||
|
[ scan , \ } parse-until % ] { } make ;
|
||||||
|
|
||||||
|
: parse-slot-name ( string/f -- ? )
|
||||||
#! This isn't meant to enforce any kind of policy, just
|
#! This isn't meant to enforce any kind of policy, just
|
||||||
#! to check for mistakes of this form:
|
#! to check for mistakes of this form:
|
||||||
#!
|
#!
|
||||||
#! TUPLE: blahblah foo bing
|
#! TUPLE: blahblah foo bing
|
||||||
#!
|
#!
|
||||||
#! : ...
|
#! : ...
|
||||||
scan {
|
{
|
||||||
{ [ dup not ] [ unexpected-eof ] }
|
{ [ dup not ] [ unexpected-eof ] }
|
||||||
{ [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
|
{ [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
|
||||||
{ [ dup ";" = ] [ drop ] }
|
{ [ dup ";" = ] [ drop f ] }
|
||||||
[ , (parse-tuple-slots) ]
|
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: parse-tuple-slots ( -- seq )
|
: parse-tuple-slots ( -- )
|
||||||
[ (parse-tuple-slots) ] { } make ;
|
scan parse-slot-name [ parse-tuple-slots ] when ;
|
||||||
|
|
||||||
: parse-tuple-definition ( -- class superclass slots )
|
: parse-tuple-definition ( -- class superclass slots )
|
||||||
CREATE-CLASS
|
CREATE-CLASS
|
||||||
scan {
|
scan {
|
||||||
{ ";" [ tuple f ] }
|
{ ";" [ tuple f ] }
|
||||||
{ "<" [ scan-word parse-tuple-slots ] }
|
{ "<" [ scan-word [ parse-tuple-slots ] { } make ] }
|
||||||
[ >r tuple parse-tuple-slots r> prefix ]
|
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
|
||||||
} case 3dup check-slot-shadowing ;
|
} case 3dup check-slot-shadowing ;
|
||||||
|
|
|
@ -1,8 +1,40 @@
|
||||||
USING: generic help.markup help.syntax kernel
|
USING: generic help.markup help.syntax kernel
|
||||||
classes.tuple.private classes slots quotations words arrays
|
classes.tuple.private classes slots quotations words arrays
|
||||||
generic.standard sequences definitions compiler.units ;
|
generic.standard sequences definitions compiler.units
|
||||||
|
growable vectors sbufs assocs math ;
|
||||||
IN: classes.tuple
|
IN: classes.tuple
|
||||||
|
|
||||||
|
ARTICLE: "slot-read-only-declaration" "Read-only slots"
|
||||||
|
"By default, all slots are writable. If a slot is explicitly declared " { $link read-only } ", then no writer method is generated for the slot, and the only way to set it to a value other than its initial value is to construct an instance of the tuple with " { $link boa } ", passing the initial value for the read-only slot on the stack; the common idiom of calling " { $link new } " and then immediately filling in slot values with setter words will not work with read-only slots." ;
|
||||||
|
|
||||||
|
ARTICLE: "slot-class-declaration" "Slot class declarations"
|
||||||
|
"Class declaration is optional, and the default value is " { $link object } ", the class of all objects. If a more specific class is declared, then the object system maintains an invariant that the value of the slot must always be an instance of the class, even during construction. This invariant is enforced at a number of locations:"
|
||||||
|
{ $list
|
||||||
|
{ "Writer words (" { $link "accessors" } ") throw an error if the new value does not satisfy the class predicate." }
|
||||||
|
{ "The " { $link new } " word fills in slots with their initial values; the (per-class) initial values are required to satisfy the class predicate." }
|
||||||
|
{ "The " { $link boa } " word ensures that the values on the stack satisfy the class predicate." }
|
||||||
|
{ { $link "mirrors" } " ensure that the value passed to " { $link set-at } " satisfies the class predicate." }
|
||||||
|
{ "The " { $link slots>tuple } " and " { $link >tuple } " words ensure that the values in the sequence satisfy the correct class predicates." }
|
||||||
|
{ { $link "tuple-redefinition" } " fills in new slots with initial values and ensures that changes to existing declarations result in incompatible values being replaced with the initial value of their respective slots." }
|
||||||
|
}
|
||||||
|
{ $subsection "slot-class-coercion" } ;
|
||||||
|
|
||||||
|
ARTICLE: "slot-class-coercion" "Coercive slot declarations"
|
||||||
|
"If the class of a slot is declared to be one of " { $link fixnum } " or " { $link float } ", then rather than testing values with the class predicate, writer words coerce values to the relevant type with " { $link >fixnum } " or " { $link >float } ". This may still result in error, but permits a wider range of values than a class predicate test. It also results in a possible loss of precision; for example, storing a large integer into a " { $link fixnum } " slot will silently overflow and discard high bits, and storing a ratio into a " { $link float } " slot may lose precision if the ratio is one which cannot be represented exactly with floating-point."
|
||||||
|
$nl
|
||||||
|
"This feature is mostly intended as an optimization for low-level code designed to avoid integer overflow, or where floating point precision is sufficient. Most code needs to work transparently with large integers, and thus hsould avoid the coercion behavior by using " { $link integer } " and " { $link real } " in place of " { $link fixnum } " and " { $link float } "." ;
|
||||||
|
|
||||||
|
ARTICLE: "tuple-declarations" "Tuple slot declarations"
|
||||||
|
"The slot specifier syntax of the " { $link POSTPONE: TUPLE: } " parsing word understands the following slot attributes:"
|
||||||
|
{ $list
|
||||||
|
"class declaration: values must satisfy the class predicate"
|
||||||
|
{ "whether a slot is read only or not (" { $link read-only } ")" }
|
||||||
|
{ "an initial value (" { $link initial: } ")" }
|
||||||
|
}
|
||||||
|
{ $subsection "slot-read-only-declaration" }
|
||||||
|
{ $subsection "slot-class-declaration" }
|
||||||
|
{ $subsection "slot-initial-values" } ;
|
||||||
|
|
||||||
ARTICLE: "parametrized-constructors" "Parameterized constructors"
|
ARTICLE: "parametrized-constructors" "Parameterized constructors"
|
||||||
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
|
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
|
||||||
$nl
|
$nl
|
||||||
|
@ -58,22 +90,30 @@ ARTICLE: "tuple-constructors" "Tuple constructors"
|
||||||
{ $subsection POSTPONE: C: }
|
{ $subsection POSTPONE: C: }
|
||||||
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
|
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
|
||||||
$nl
|
$nl
|
||||||
|
"Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple will initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "."
|
||||||
|
$nl
|
||||||
"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
|
"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
|
||||||
$nl
|
$nl
|
||||||
"Examples of constructors:"
|
"Examples of constructors:"
|
||||||
{ $code
|
{ $code
|
||||||
"TUPLE: color red green blue alpha ;"
|
"TUPLE: color"
|
||||||
|
"{ red integer }"
|
||||||
|
"{ green integer }"
|
||||||
|
"{ blue integer }"
|
||||||
|
"{ alpha integer initial: 1 } ;"
|
||||||
""
|
""
|
||||||
"! The following two are equivalent"
|
"! The following two are equivalent"
|
||||||
"C: <rgba> rgba"
|
"C: <rgba> rgba"
|
||||||
": <rgba> color boa ;"
|
": <rgba> color boa ;"
|
||||||
""
|
""
|
||||||
"! We can define constructors which call other constructors"
|
"! We can define constructors which call other constructors"
|
||||||
": <rgb> f <rgba> ;"
|
": <rgb> 1 <rgba> ;"
|
||||||
""
|
""
|
||||||
"! The following two are equivalent"
|
"! The following two are equivalent; note the initial value"
|
||||||
": <color> color new ;"
|
": <color> ( -- color ) color new ;"
|
||||||
": <color> f f f f <rgba> ;"
|
": <color> ( -- color ) 0 0 0 1 <rgba> ;"
|
||||||
|
"! Run-time error"
|
||||||
|
"\"not a number\" 2 3 4 color boa"
|
||||||
}
|
}
|
||||||
{ $subsection "parametrized-constructors" } ;
|
{ $subsection "parametrized-constructors" } ;
|
||||||
|
|
||||||
|
@ -225,37 +265,66 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
||||||
ARTICLE: "tuple-redefinition" "Tuple redefinition"
|
ARTICLE: "tuple-redefinition" "Tuple redefinition"
|
||||||
"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses."
|
"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses."
|
||||||
$nl
|
$nl
|
||||||
"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "."
|
"When the " { $emphasis "effective slots" } " of a tuple class change, all instances of the class, including subclasses, are updated."
|
||||||
$nl
|
$nl
|
||||||
"There are three ways to change the list of effective slots of a class:"
|
"There are three ways in which the list of effective slots may change:"
|
||||||
{ $list
|
{ $list
|
||||||
"Adding or removing direct slots of the class"
|
"Adding or removing direct slots of the class"
|
||||||
"Adding or removing direct slots of a superclass of the class"
|
"Adding or removing direct slots of a superclass of the class"
|
||||||
"Changing the inheritance hierarchy by redefining a class to have a different superclass"
|
"Changing the inheritance hierarchy by changing the superclass of a class"
|
||||||
|
"Declarations changing on existing slots"
|
||||||
}
|
}
|
||||||
"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:"
|
"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:"
|
||||||
{ $list
|
{ $list
|
||||||
"If any slots were removed, the values are removed from the instance and are lost forever."
|
"If any slots were removed, the values are removed from the instance and are lost forever."
|
||||||
{ "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." }
|
"If any slots were added, the instance gains these slots, all set to their initial values."
|
||||||
"If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory."
|
"If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory."
|
||||||
|
"If the slot declaration of an existing slot changes, existing values are checked to see if they are still an instance of the required class. Any which are not are replaced by the initial value of that slot."
|
||||||
"If the number or order of effective slots changes, any BOA constructors are recompiled."
|
"If the number or order of effective slots changes, any BOA constructors are recompiled."
|
||||||
}
|
}
|
||||||
"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." ;
|
"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"
|
ARTICLE: "tuples" "Tuples"
|
||||||
"Tuples are user-defined classes composed of named slots."
|
"Tuples are user-defined classes composed of named slots. They are the central data type of Factor's object system."
|
||||||
{ $subsection "tuple-examples" }
|
{ $subsection "tuple-examples" }
|
||||||
"A parsing word defines tuple classes:"
|
"A parsing word defines tuple classes:"
|
||||||
{ $subsection POSTPONE: TUPLE: }
|
{ $subsection POSTPONE: TUPLE: }
|
||||||
"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
|
"For each tuple class, several words are defined, the class word, a class predicate, and accessor words for each slot."
|
||||||
$nl
|
$nl
|
||||||
"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
|
"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly, and tuple slots are accessed via automatically-generated accessor words."
|
||||||
{ $subsection "accessors" }
|
{ $subsection "accessors" }
|
||||||
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
|
|
||||||
{ $subsection "tuple-constructors" }
|
{ $subsection "tuple-constructors" }
|
||||||
"Expressing relationships through the object system:"
|
|
||||||
{ $subsection "tuple-subclassing" }
|
{ $subsection "tuple-subclassing" }
|
||||||
"Introspection:"
|
{ $subsection "tuple-declarations" }
|
||||||
|
{ $subsection "protocol-slots" }
|
||||||
{ $subsection "tuple-introspection" }
|
{ $subsection "tuple-introspection" }
|
||||||
"Tuple classes can be redefined; this updates existing instances:"
|
"Tuple classes can be redefined; this updates existing instances:"
|
||||||
{ $subsection "tuple-redefinition" }
|
{ $subsection "tuple-redefinition" }
|
||||||
|
@ -337,7 +406,7 @@ HELP: <tuple-boa> ( ... layout -- tuple )
|
||||||
|
|
||||||
HELP: new
|
HELP: new
|
||||||
{ $values { "class" tuple-class } { "tuple" tuple } }
|
{ $values { "class" tuple-class } { "tuple" tuple } }
|
||||||
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
|
{ $description "Creates a new instance of " { $snippet "class" } " with all slots set to their initial values (see" { $link "tuple-declarations" } ")." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example
|
{ $example
|
||||||
"USING: kernel prettyprint ;"
|
"USING: kernel prettyprint ;"
|
||||||
|
@ -373,4 +442,5 @@ HELP: construct
|
||||||
HELP: boa
|
HELP: boa
|
||||||
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
|
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
|
||||||
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
|
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
|
||||||
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
|
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." }
|
||||||
|
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;
|
||||||
|
|
|
@ -3,8 +3,8 @@ math.constants parser sequences tools.test words assocs
|
||||||
namespaces quotations sequences.private classes continuations
|
namespaces quotations sequences.private classes continuations
|
||||||
generic.standard effects classes.tuple classes.tuple.private
|
generic.standard effects classes.tuple classes.tuple.private
|
||||||
arrays vectors strings compiler.units accessors classes.algebra
|
arrays vectors strings compiler.units accessors classes.algebra
|
||||||
calendar prettyprint io.streams.string splitting inspector
|
calendar prettyprint io.streams.string splitting summary
|
||||||
columns math.order classes.private slots.private ;
|
columns math.order classes.private slots slots.private ;
|
||||||
IN: classes.tuple.tests
|
IN: classes.tuple.tests
|
||||||
|
|
||||||
TUPLE: rect x y w h ;
|
TUPLE: rect x y w h ;
|
||||||
|
@ -88,20 +88,20 @@ C: <empty> empty
|
||||||
[ t length ] [ object>> t eq? ] must-fail-with
|
[ t length ] [ object>> t eq? ] must-fail-with
|
||||||
|
|
||||||
[ "<constructor-test>" ]
|
[ "<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 ;
|
TUPLE: size-test a b c d ;
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
T{ size-test } tuple-size
|
T{ size-test } tuple-size
|
||||||
size-test tuple-layout layout-size =
|
size-test tuple-layout size>> =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
GENERIC: <yo-momma>
|
GENERIC: <yo-momma>
|
||||||
|
|
||||||
TUPLE: yo-momma ;
|
TUPLE: yo-momma ;
|
||||||
|
|
||||||
"IN: classes.tuple.tests C: <yo-momma> yo-momma" eval
|
[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval ] unit-test
|
||||||
|
|
||||||
[ f ] [ \ <yo-momma> generic? ] unit-test
|
[ f ] [ \ <yo-momma> generic? ] unit-test
|
||||||
|
|
||||||
|
@ -190,15 +190,6 @@ M: vector silly "z" ;
|
||||||
! Typo
|
! Typo
|
||||||
SYMBOL: not-a-tuple-class
|
SYMBOL: not-a-tuple-class
|
||||||
|
|
||||||
[
|
|
||||||
"IN: classes.tuple.tests C: <not-a-tuple-class> not-a-tuple-class"
|
|
||||||
eval
|
|
||||||
] must-fail
|
|
||||||
|
|
||||||
[ t ] [
|
|
||||||
"not-a-tuple-class" "classes.tuple.tests" lookup symbol?
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
! Missing check
|
! Missing check
|
||||||
[ not-a-tuple-class boa ] must-fail
|
[ not-a-tuple-class boa ] must-fail
|
||||||
[ not-a-tuple-class new ] must-fail
|
[ not-a-tuple-class new ] must-fail
|
||||||
|
@ -212,16 +203,12 @@ C: <erg's-reshape-problem> erg's-reshape-problem
|
||||||
: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
|
: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
|
||||||
: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
|
: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
|
||||||
|
|
||||||
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
|
[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test
|
||||||
|
|
||||||
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
|
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
|
||||||
|
|
||||||
[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
|
[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
|
||||||
|
|
||||||
[
|
|
||||||
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
|
|
||||||
] [ error>> not-a-tuple-class? ] must-fail-with
|
|
||||||
|
|
||||||
! Inheritance
|
! Inheritance
|
||||||
TUPLE: computer cpu ram ;
|
TUPLE: computer cpu ram ;
|
||||||
C: <computer> computer
|
C: <computer> computer
|
||||||
|
@ -253,8 +240,8 @@ test-laptop-slot-values
|
||||||
|
|
||||||
[ laptop ] [
|
[ laptop ] [
|
||||||
"laptop" get 1 slot
|
"laptop" get 1 slot
|
||||||
dup layout-echelon swap
|
dup echelon>> swap
|
||||||
layout-superclasses nth
|
superclasses>> nth
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "TUPLE: laptop < computer battery ;" ] [
|
[ "TUPLE: laptop < computer battery ;" ] [
|
||||||
|
@ -361,7 +348,7 @@ test-server-slot-values
|
||||||
[ 110 ] [ "server" get voltage>> ] unit-test
|
[ 110 ] [ "server" get voltage>> ] unit-test
|
||||||
|
|
||||||
! Reshaping superclass and subclass simultaneously
|
! Reshaping superclass and subclass simultaneously
|
||||||
"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval
|
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
|
||||||
|
|
||||||
test-laptop-slot-values
|
test-laptop-slot-values
|
||||||
test-server-slot-values
|
test-server-slot-values
|
||||||
|
@ -490,7 +477,9 @@ USE: vocabs
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "USE: words T{ word }" eval ] [ error>> not-a-tuple-class? ] must-fail-with
|
[ "USE: words T{ word }" eval ]
|
||||||
|
[ error>> T{ no-method f word slots>tuple } = ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
! Accessors not being forgotten...
|
! Accessors not being forgotten...
|
||||||
[ [ ] ] [
|
[ [ ] ] [
|
||||||
|
@ -598,3 +587,97 @@ GENERIC: break-me ( obj -- )
|
||||||
|
|
||||||
! Insufficient type checking
|
! Insufficient type checking
|
||||||
[ \ vocab tuple>array drop ] must-fail
|
[ \ vocab tuple>array drop ] must-fail
|
||||||
|
|
||||||
|
! Check type declarations
|
||||||
|
TUPLE: declared-types { n fixnum } { m string } ;
|
||||||
|
|
||||||
|
[ T{ declared-types f 0 "hi" } ]
|
||||||
|
[ { declared-types f 0 "hi" } >tuple ]
|
||||||
|
unit-test
|
||||||
|
|
||||||
|
[ { declared-types f "hi" 0 } >tuple ]
|
||||||
|
[ T{ bad-slot-value f "hi" fixnum } = ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ T{ declared-types f 0 "hi" } ]
|
||||||
|
[ 0.0 "hi" declared-types boa ] unit-test
|
||||||
|
|
||||||
|
: foo ( a b -- c ) declared-types boa ;
|
||||||
|
|
||||||
|
\ foo must-infer
|
||||||
|
|
||||||
|
[ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
|
||||||
|
|
||||||
|
[ "hi" 0.0 declared-types boa ]
|
||||||
|
[ T{ no-method f "hi" >fixnum } = ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ 0 { } declared-types boa ]
|
||||||
|
[ T{ bad-slot-value f { } string } = ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ "hi" 0.0 foo ]
|
||||||
|
[ T{ no-method f "hi" >fixnum } = ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ 0 { } foo ]
|
||||||
|
[ T{ bad-slot-value f { } string } = ]
|
||||||
|
must-fail-with
|
||||||
|
|
||||||
|
[ T{ declared-types f 0 "" } ] [ declared-types new ] unit-test
|
||||||
|
|
||||||
|
: blah ( -- vec ) vector new ;
|
||||||
|
|
||||||
|
\ blah must-infer
|
||||||
|
|
||||||
|
[ V{ } ] [ blah ] unit-test
|
||||||
|
|
||||||
|
! Test reshaping with type declarations and slot attributes
|
||||||
|
TUPLE: reshape-test x ;
|
||||||
|
|
||||||
|
T{ reshape-test f "hi" } "tuple" set
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ f ] [ \ reshape-test \ (>>x) method ] unit-test
|
||||||
|
|
||||||
|
[ "tuple" get 5 >>x ] must-fail
|
||||||
|
|
||||||
|
[ "hi" ] [ "tuple" get x>> ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ 0 ] [ "tuple" get x>> ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ 0 ] [ "tuple" get x>> ] unit-test
|
||||||
|
|
||||||
|
TUPLE: boa-coercer-test { x array-capacity } ;
|
||||||
|
|
||||||
|
[ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test
|
||||||
|
|
||||||
|
! Test error classes
|
||||||
|
ERROR: error-class-test a b c ;
|
||||||
|
|
||||||
|
[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
|
||||||
|
[ f ] [ \ error-class-test "inline" word-prop ] unit-test
|
||||||
|
|
||||||
|
[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ]
|
||||||
|
[ error>> error>> redefine-error? ] must-fail-with
|
||||||
|
|
||||||
|
DEFER: error-y
|
||||||
|
|
||||||
|
[ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.tuple.tests GENERIC: error-y" eval ] unit-test
|
||||||
|
|
||||||
|
[ f ] [ \ error-y tuple-class? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ \ error-y generic? ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ \ error-y tuple-class? ] unit-test
|
||||||
|
|
||||||
|
[ f ] [ \ error-y generic? ] unit-test
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays definitions hashtables kernel
|
USING: arrays definitions hashtables kernel kernel.private math
|
||||||
kernel.private math namespaces sequences sequences.private
|
namespaces sequences sequences.private strings vectors words
|
||||||
strings vectors words quotations memory combinators generic
|
quotations memory combinators generic classes classes.algebra
|
||||||
classes classes.private slots.deprecated slots.private slots
|
classes.private slots.deprecated slots.private slots
|
||||||
compiler.units math.private accessors assocs ;
|
compiler.units math.private accessors assocs effects ;
|
||||||
IN: classes.tuple
|
IN: classes.tuple
|
||||||
|
|
||||||
M: tuple class 1 slot 2 slot { word } declare ;
|
M: tuple class 1 slot 2 slot { word } declare ;
|
||||||
|
@ -14,21 +14,31 @@ ERROR: not-a-tuple object ;
|
||||||
: check-tuple ( object -- tuple )
|
: check-tuple ( object -- tuple )
|
||||||
dup tuple? [ not-a-tuple ] unless ; inline
|
dup tuple? [ not-a-tuple ] unless ; inline
|
||||||
|
|
||||||
ERROR: not-a-tuple-class class ;
|
|
||||||
|
|
||||||
: check-tuple-class ( class -- class )
|
|
||||||
dup tuple-class? [ not-a-tuple-class ] unless ; inline
|
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
: (tuple) ( layout -- tuple )
|
||||||
|
#! In non-optimized code, this word simply calls the
|
||||||
|
#! <tuple> primitive. In optimized code, an intrinsic
|
||||||
|
#! is generated which allocates a tuple but does not set
|
||||||
|
#! any of its slots. This means that any code that uses
|
||||||
|
#! (tuple) must fill in the slots before the next
|
||||||
|
#! call to GC.
|
||||||
|
#!
|
||||||
|
#! This word is only used in the expansion of <tuple-boa>,
|
||||||
|
#! where this invariant is guaranteed to hold.
|
||||||
|
<tuple> ;
|
||||||
|
|
||||||
: tuple-layout ( class -- layout )
|
: tuple-layout ( class -- layout )
|
||||||
check-tuple-class "layout" word-prop ;
|
"layout" word-prop ;
|
||||||
|
|
||||||
|
: layout-of ( tuple -- layout )
|
||||||
|
1 slot { tuple-layout } declare ; inline
|
||||||
|
|
||||||
: tuple-size ( tuple -- size )
|
: tuple-size ( tuple -- size )
|
||||||
1 slot layout-size ; inline
|
layout-of size>> ; inline
|
||||||
|
|
||||||
: prepare-tuple>array ( tuple -- n tuple layout )
|
: prepare-tuple>array ( tuple -- n tuple layout )
|
||||||
check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ;
|
check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
|
||||||
|
|
||||||
: copy-tuple-slots ( n tuple -- array )
|
: copy-tuple-slots ( n tuple -- array )
|
||||||
[ array-nth ] curry map ;
|
[ array-nth ] curry map ;
|
||||||
|
@ -38,75 +48,100 @@ PRIVATE>
|
||||||
: tuple>array ( tuple -- array )
|
: tuple>array ( tuple -- array )
|
||||||
prepare-tuple>array
|
prepare-tuple>array
|
||||||
>r copy-tuple-slots r>
|
>r copy-tuple-slots r>
|
||||||
layout-class prefix ;
|
class>> prefix ;
|
||||||
|
|
||||||
: tuple-slots ( tuple -- seq )
|
: tuple-slots ( tuple -- seq )
|
||||||
prepare-tuple>array drop copy-tuple-slots ;
|
prepare-tuple>array drop copy-tuple-slots ;
|
||||||
|
|
||||||
: slots>tuple ( tuple class -- array )
|
: all-slots ( class -- slots )
|
||||||
|
superclasses [ "slots" word-prop ] map concat ;
|
||||||
|
|
||||||
|
: check-slots ( seq class -- seq class )
|
||||||
|
[ ] [
|
||||||
|
2dup all-slots [
|
||||||
|
class>> 2dup instance?
|
||||||
|
[ 2drop ] [ bad-slot-value ] if
|
||||||
|
] 2each
|
||||||
|
] if-bootstrapping ; inline
|
||||||
|
|
||||||
|
GENERIC: slots>tuple ( seq class -- tuple )
|
||||||
|
|
||||||
|
M: tuple-class slots>tuple
|
||||||
|
check-slots
|
||||||
tuple-layout <tuple> [
|
tuple-layout <tuple> [
|
||||||
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
|
[ tuple-size ]
|
||||||
|
[ [ set-array-nth ] curry ]
|
||||||
|
bi 2each
|
||||||
] keep ;
|
] keep ;
|
||||||
|
|
||||||
: >tuple ( tuple -- seq )
|
: >tuple ( seq -- tuple )
|
||||||
unclip slots>tuple ;
|
unclip slots>tuple ;
|
||||||
|
|
||||||
: slot-names ( class -- seq )
|
: slot-names ( class -- seq )
|
||||||
"slot-names" word-prop
|
"slot-names" word-prop ;
|
||||||
[ dup array? [ second ] when ] map ;
|
|
||||||
|
|
||||||
: all-slot-names ( class -- slots )
|
|
||||||
superclasses [ slot-names ] map concat \ class prefix ;
|
|
||||||
|
|
||||||
ERROR: bad-superclass class ;
|
ERROR: bad-superclass class ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: tuple= ( tuple1 tuple2 -- ? )
|
: tuple= ( tuple1 tuple2 -- ? )
|
||||||
2dup [ 1 slot ] bi@ eq? [
|
2dup [ layout-of ] bi@ eq? [
|
||||||
[ drop tuple-size ]
|
[ drop tuple-size ]
|
||||||
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
|
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
|
||||||
2bi all-integers?
|
2bi all-integers?
|
||||||
] [
|
] [
|
||||||
2drop f
|
2drop f
|
||||||
] if ;
|
] if ; inline
|
||||||
|
|
||||||
! Predicate generation. We optimize at the expense of simplicity
|
: tuple-instance? ( object class echelon -- ? )
|
||||||
|
#! 4 slot == superclasses>>
|
||||||
: (tuple-predicate-quot) ( class -- quot )
|
rot dup tuple? [
|
||||||
#! 4 slot == layout-superclasses
|
layout-of 4 slot
|
||||||
#! 5 slot == layout-echelon
|
2dup array-capacity fixnum<
|
||||||
[
|
[ array-nth eq? ] [ 3drop f ] if
|
||||||
[ 1 slot dup 5 slot ] %
|
] [ 3drop f ] if ; inline
|
||||||
dup tuple-layout layout-echelon ,
|
|
||||||
[ fixnum>= ] %
|
|
||||||
[
|
|
||||||
dup tuple-layout layout-echelon ,
|
|
||||||
[ swap 4 slot array-nth ] %
|
|
||||||
literalize ,
|
|
||||||
[ eq? ] %
|
|
||||||
] [ ] make ,
|
|
||||||
[ drop f ] ,
|
|
||||||
\ if ,
|
|
||||||
] [ ] make ;
|
|
||||||
|
|
||||||
: tuple-predicate-quot ( class -- quot )
|
|
||||||
[
|
|
||||||
[ dup tuple? ] %
|
|
||||||
(tuple-predicate-quot) ,
|
|
||||||
[ drop f ] ,
|
|
||||||
\ if ,
|
|
||||||
] [ ] make ;
|
|
||||||
|
|
||||||
: define-tuple-predicate ( class -- )
|
: define-tuple-predicate ( class -- )
|
||||||
dup tuple-predicate-quot define-predicate ;
|
dup dup tuple-layout echelon>>
|
||||||
|
[ tuple-instance? ] 2curry define-predicate ;
|
||||||
|
|
||||||
: superclass-size ( class -- n )
|
: superclass-size ( class -- n )
|
||||||
superclasses but-last-slice
|
superclasses but-last-slice
|
||||||
[ slot-names length ] sigma ;
|
[ slot-names length ] sigma ;
|
||||||
|
|
||||||
|
: (instance-check-quot) ( class -- quot )
|
||||||
|
[
|
||||||
|
\ dup ,
|
||||||
|
[ "predicate" word-prop % ]
|
||||||
|
[ [ bad-slot-value ] curry , ] bi
|
||||||
|
\ unless ,
|
||||||
|
] [ ] make ;
|
||||||
|
|
||||||
|
: (fixnum-check-quot) ( class -- quot )
|
||||||
|
(instance-check-quot) fixnum "coercer" word-prop prepend ;
|
||||||
|
|
||||||
|
: instance-check-quot ( class -- quot )
|
||||||
|
{
|
||||||
|
{ [ dup object bootstrap-word eq? ] [ drop [ ] ] }
|
||||||
|
{ [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
|
||||||
|
{ [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
|
||||||
|
[ (instance-check-quot) ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: boa-check-quot ( class -- quot )
|
||||||
|
all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ;
|
||||||
|
|
||||||
|
: define-boa-check ( class -- )
|
||||||
|
dup boa-check-quot "boa-check" set-word-prop ;
|
||||||
|
|
||||||
|
: tuple-prototype ( class -- prototype )
|
||||||
|
[ all-slots [ initial>> ] map ] keep slots>tuple ;
|
||||||
|
|
||||||
|
: define-tuple-prototype ( class -- )
|
||||||
|
dup tuple-prototype "prototype" set-word-prop ;
|
||||||
|
|
||||||
: generate-tuple-slots ( class slots -- slot-specs )
|
: 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 -- )
|
: define-tuple-slots ( class -- )
|
||||||
dup dup "slot-names" word-prop generate-tuple-slots
|
dup dup "slot-names" word-prop generate-tuple-slots
|
||||||
|
@ -124,40 +159,54 @@ ERROR: bad-superclass class ;
|
||||||
: define-tuple-layout ( class -- )
|
: define-tuple-layout ( class -- )
|
||||||
dup make-tuple-layout "layout" set-word-prop ;
|
dup make-tuple-layout "layout" set-word-prop ;
|
||||||
|
|
||||||
: compute-slot-permutation ( class old-slot-names -- permutation )
|
: compute-slot-permutation ( new-slots old-slots -- triples )
|
||||||
>r all-slot-names r> [ index ] curry map ;
|
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
|
||||||
|
[ drop [ class>> ] map ]
|
||||||
|
[ drop [ initial>> ] map ]
|
||||||
|
2tri 3array flip ;
|
||||||
|
|
||||||
: apply-slot-permutation ( old-values permutation -- new-values )
|
: update-slot ( old-values n class initial -- value )
|
||||||
[ [ swap ?nth ] [ drop f ] if* ] with map ;
|
pick [
|
||||||
|
>r >r swap nth dup r> instance?
|
||||||
|
[ r> drop ] [ drop r> ] if
|
||||||
|
] [ >r 3drop r> ] if ;
|
||||||
|
|
||||||
: permute-slots ( old-values -- new-values )
|
: apply-slot-permutation ( old-values triples -- new-values )
|
||||||
dup first dup outdated-tuples get at
|
[ first3 update-slot ] with map ;
|
||||||
|
|
||||||
|
: permute-slots ( old-values layout -- new-values )
|
||||||
|
[ class>> all-slots ] [ outdated-tuples get at ] bi
|
||||||
compute-slot-permutation
|
compute-slot-permutation
|
||||||
apply-slot-permutation ;
|
apply-slot-permutation ;
|
||||||
|
|
||||||
: change-tuple ( tuple quot -- newtuple )
|
|
||||||
>r tuple>array r> call >tuple ; inline
|
|
||||||
|
|
||||||
: update-tuple ( tuple -- newtuple )
|
: update-tuple ( tuple -- newtuple )
|
||||||
[ permute-slots ] change-tuple ;
|
[ tuple-slots ] [ layout-of ] bi
|
||||||
|
[ permute-slots ] [ class>> ] bi
|
||||||
|
slots>tuple ;
|
||||||
|
|
||||||
: update-tuples ( -- )
|
: update-tuples ( -- )
|
||||||
outdated-tuples get
|
outdated-tuples get
|
||||||
dup assoc-empty? [ drop ] [
|
dup assoc-empty? [ drop ] [
|
||||||
[ >r class r> key? ] curry instances
|
[
|
||||||
|
over tuple?
|
||||||
|
[ >r layout-of r> key? ] [ 2drop f ] if
|
||||||
|
] curry instances
|
||||||
dup [ update-tuple ] map become
|
dup [ update-tuple ] map become
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
[ update-tuples ] update-tuples-hook set-global
|
[ update-tuples ] update-tuples-hook set-global
|
||||||
|
|
||||||
: update-tuples-after ( class -- )
|
: update-tuples-after ( class -- )
|
||||||
outdated-tuples get [ all-slot-names ] cache drop ;
|
[ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
|
||||||
|
|
||||||
M: tuple-class update-class
|
M: tuple-class update-class
|
||||||
[ define-tuple-layout ]
|
{
|
||||||
[ define-tuple-slots ]
|
[ define-tuple-layout ]
|
||||||
[ define-tuple-predicate ]
|
[ define-tuple-slots ]
|
||||||
tri ;
|
[ define-tuple-predicate ]
|
||||||
|
[ define-tuple-prototype ]
|
||||||
|
[ define-boa-check ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
: define-new-tuple-class ( class superclass slots -- )
|
: define-new-tuple-class ( class superclass slots -- )
|
||||||
[ drop f f tuple-class define-class ]
|
[ drop f f tuple-class define-class ]
|
||||||
|
@ -202,28 +251,44 @@ M: word define-tuple-class
|
||||||
define-new-tuple-class ;
|
define-new-tuple-class ;
|
||||||
|
|
||||||
M: tuple-class define-tuple-class
|
M: tuple-class define-tuple-class
|
||||||
|
over check-superclass
|
||||||
3dup tuple-class-unchanged?
|
3dup tuple-class-unchanged?
|
||||||
[ over check-superclass 3dup redefine-tuple-class ] unless
|
[ 3drop ] [ redefine-tuple-class ] if ;
|
||||||
3drop ;
|
|
||||||
|
: thrower-effect ( slots -- effect )
|
||||||
|
[ dup array? [ first ] when ] map f <effect> t >>terminated? ;
|
||||||
|
|
||||||
: define-error-class ( class superclass slots -- )
|
: define-error-class ( class superclass slots -- )
|
||||||
[ define-tuple-class ] [ 2drop ] 3bi
|
[ define-tuple-class ]
|
||||||
dup [ boa throw ] curry define ;
|
[ 2drop reset-generic ]
|
||||||
|
[
|
||||||
|
[ dup [ boa throw ] curry ]
|
||||||
|
[ drop ]
|
||||||
|
[ thrower-effect ]
|
||||||
|
tri* define-declared
|
||||||
|
] 3tri ;
|
||||||
|
|
||||||
M: tuple-class reset-class
|
M: tuple-class reset-class
|
||||||
[
|
[
|
||||||
dup "slot-names" word-prop [
|
dup "slots" word-prop [
|
||||||
|
name>>
|
||||||
[ reader-word method forget ]
|
[ reader-word method forget ]
|
||||||
[ writer-word method forget ] 2bi
|
[ writer-word method forget ] 2bi
|
||||||
] with each
|
] with each
|
||||||
] [
|
] [
|
||||||
[ call-next-method ]
|
[ call-next-method ]
|
||||||
[ { "layout" "slots" } reset-props ]
|
[
|
||||||
bi
|
{
|
||||||
|
"layout" "slots" "slot-names" "boa-check" "prototype"
|
||||||
|
} reset-props
|
||||||
|
] bi
|
||||||
] bi ;
|
] bi ;
|
||||||
|
|
||||||
M: tuple-class rank-class drop 0 ;
|
M: tuple-class rank-class drop 0 ;
|
||||||
|
|
||||||
|
M: tuple-class instance?
|
||||||
|
dup tuple-layout echelon>> tuple-instance? ;
|
||||||
|
|
||||||
M: tuple clone
|
M: tuple clone
|
||||||
(clone) dup delegate clone over set-delegate ;
|
(clone) dup delegate clone over set-delegate ;
|
||||||
|
|
||||||
|
@ -238,6 +303,14 @@ M: tuple hashcode*
|
||||||
] 2curry each
|
] 2curry each
|
||||||
] recursive-hashcode ;
|
] recursive-hashcode ;
|
||||||
|
|
||||||
|
M: tuple-class new
|
||||||
|
"prototype" word-prop (clone) ;
|
||||||
|
|
||||||
|
M: tuple-class boa
|
||||||
|
[ "boa-check" word-prop call ]
|
||||||
|
[ tuple-layout ]
|
||||||
|
bi <tuple-boa> ;
|
||||||
|
|
||||||
! Deprecated
|
! Deprecated
|
||||||
M: object get-slots ( obj slots -- ... )
|
M: object get-slots ( obj slots -- ... )
|
||||||
[ execute ] with each ;
|
[ execute ] with each ;
|
||||||
|
|
|
@ -0,0 +1,88 @@
|
||||||
|
USING: alien arrays definitions generic assocs hashtables io
|
||||||
|
kernel math namespaces parser prettyprint sequences strings
|
||||||
|
tools.test vectors words quotations classes
|
||||||
|
classes.private classes.union classes.mixin classes.predicate
|
||||||
|
classes.algebra vectors definitions source-files
|
||||||
|
compiler.units kernel.private sorting vocabs io.streams.string ;
|
||||||
|
IN: classes.union.tests
|
||||||
|
|
||||||
|
! DEFER: bah
|
||||||
|
! FORGET: bah
|
||||||
|
UNION: bah fixnum alien ;
|
||||||
|
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
|
||||||
|
|
||||||
|
[ "USING: alien math ;\nIN: classes.union.tests\nUNION: bah fixnum alien ;\n" ]
|
||||||
|
[ [ \ bah see ] with-string-writer ] unit-test
|
||||||
|
|
||||||
|
! Test redefinition of classes
|
||||||
|
UNION: union-1 fixnum float ;
|
||||||
|
|
||||||
|
GENERIC: generic-update-test ( x -- y )
|
||||||
|
|
||||||
|
M: union-1 generic-update-test drop "union-1" ;
|
||||||
|
|
||||||
|
[ f ] [ bignum union-1 class<= ] unit-test
|
||||||
|
[ t ] [ union-1 number class<= ] unit-test
|
||||||
|
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
|
||||||
|
|
||||||
|
"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
|
||||||
|
|
||||||
|
[ t ] [ bignum union-1 class<= ] unit-test
|
||||||
|
[ f ] [ union-1 number class<= ] unit-test
|
||||||
|
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
|
||||||
|
|
||||||
|
"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval
|
||||||
|
|
||||||
|
[ f ] [ union-1 union-class? ] unit-test
|
||||||
|
[ t ] [ union-1 predicate-class? ] unit-test
|
||||||
|
[ "union-1" ] [ 8 generic-update-test ] unit-test
|
||||||
|
[ -7 generic-update-test ] must-fail
|
||||||
|
|
||||||
|
! Empty unions were causing problems
|
||||||
|
GENERIC: empty-union-test ( obj -- obj )
|
||||||
|
|
||||||
|
UNION: empty-union-1 ;
|
||||||
|
|
||||||
|
M: empty-union-1 empty-union-test ;
|
||||||
|
|
||||||
|
UNION: empty-union-2 ;
|
||||||
|
|
||||||
|
M: empty-union-2 empty-union-test ;
|
||||||
|
|
||||||
|
! Redefining a class didn't update containing unions
|
||||||
|
UNION: redefine-bug-1 fixnum ;
|
||||||
|
|
||||||
|
UNION: redefine-bug-2 redefine-bug-1 quotation ;
|
||||||
|
|
||||||
|
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
|
||||||
|
[ t ] [ quotation redefine-bug-2 class<= ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ bignum redefine-bug-1 class<= ] unit-test
|
||||||
|
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
|
||||||
|
[ t ] [ bignum redefine-bug-2 class<= ] unit-test
|
||||||
|
|
||||||
|
! Too eager with reset-class
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.union.tests SINGLETON: foo UNION: blah foo ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.union.tests USE: math UNION: blah integer ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
|
||||||
|
|
||||||
|
GENERIC: test-generic ( x -- y )
|
||||||
|
|
||||||
|
TUPLE: a-tuple ;
|
||||||
|
|
||||||
|
UNION: a-union a-tuple ;
|
||||||
|
|
||||||
|
M: a-union test-generic ;
|
||||||
|
|
||||||
|
[ f ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ \ a-tuple forget-class ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test
|
|
@ -29,3 +29,6 @@ M: union-class update-class define-union-predicate ;
|
||||||
[ (define-union-class) ] [ drop update-classes ] 2bi ;
|
[ (define-union-class) ] [ drop update-classes ] 2bi ;
|
||||||
|
|
||||||
M: union-class rank-class drop 2 ;
|
M: union-class rank-class drop 2 ;
|
||||||
|
|
||||||
|
M: union-class instance?
|
||||||
|
"members" word-prop [ instance? ] with contains? ;
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
USING: alien strings kernel math tools.test io prettyprint
|
USING: alien strings kernel math tools.test io prettyprint
|
||||||
namespaces combinators words classes sequences ;
|
namespaces combinators words classes sequences accessors
|
||||||
|
math.functions ;
|
||||||
IN: combinators.tests
|
IN: combinators.tests
|
||||||
|
|
||||||
! Compiled
|
! Compiled
|
||||||
|
@ -140,7 +141,7 @@ IN: combinators.tests
|
||||||
[ "two" ] [ 2 case-test-1 ] unit-test
|
[ "two" ] [ 2 case-test-1 ] unit-test
|
||||||
|
|
||||||
! Interpreted
|
! 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
|
[ "x" case-test-1 ] must-fail
|
||||||
|
|
||||||
|
@ -158,7 +159,7 @@ IN: combinators.tests
|
||||||
[ 25 ] [ 5 case-test-2 ] unit-test
|
[ 25 ] [ 5 case-test-2 ] unit-test
|
||||||
|
|
||||||
! Interpreted
|
! 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' )
|
: case-test-3 ( obj -- obj' )
|
||||||
{
|
{
|
||||||
|
@ -257,12 +258,14 @@ IN: combinators.tests
|
||||||
|
|
||||||
: do-not-call "do not call" throw ;
|
: do-not-call "do not call" throw ;
|
||||||
|
|
||||||
: test-case-6
|
: test-case-6 ( obj -- value )
|
||||||
{
|
{
|
||||||
{ \ do-not-call [ "do-not-call" ] }
|
{ \ do-not-call [ "do-not-call" ] }
|
||||||
{ 3 [ "three" ] }
|
{ 3 [ "three" ] }
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
|
\ test-case-6 must-infer
|
||||||
|
|
||||||
[ "three" ] [ 3 test-case-6 ] unit-test
|
[ "three" ] [ 3 test-case-6 ] unit-test
|
||||||
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
|
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
|
||||||
|
|
||||||
|
@ -288,11 +291,26 @@ IN: combinators.tests
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Interpreted
|
! 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
|
[ t ] [ { 1 3 2 } contiguous-range? ] unit-test
|
||||||
[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
|
[ f ] [ { 1 2 2 4 } contiguous-range? ] unit-test
|
||||||
[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
|
[ f ] [ { + 3 2 } contiguous-range? ] unit-test
|
||||||
[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
|
[ f ] [ { 1 0 7 } contiguous-range? ] unit-test
|
||||||
[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
|
[ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test
|
||||||
[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
|
[ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
|
||||||
|
|
||||||
|
: test-case-7 ( obj -- str )
|
||||||
|
{
|
||||||
|
{ \ + [ "plus" ] }
|
||||||
|
{ \ - [ "minus" ] }
|
||||||
|
{ \ * [ "times" ] }
|
||||||
|
{ \ / [ "divide" ] }
|
||||||
|
{ \ ^ [ "power" ] }
|
||||||
|
{ \ [ [ "obama" ] }
|
||||||
|
{ \ ] [ "KFC" ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
\ test-case-7 must-infer
|
||||||
|
|
||||||
|
[ "plus" ] [ \ + test-case-7 ] unit-test
|
||||||
|
|
|
@ -1,36 +1,42 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
kernel kernel.private math assocs quotations vectors
|
||||||
hashtables sorting words sets math.order ;
|
hashtables sorting words sets math.order ;
|
||||||
IN: combinators
|
IN: combinators
|
||||||
|
|
||||||
|
! cleave
|
||||||
: cleave ( x seq -- )
|
: cleave ( x seq -- )
|
||||||
[ call ] with each ;
|
[ call ] with each ;
|
||||||
|
|
||||||
: cleave>quot ( seq -- quot )
|
: cleave>quot ( seq -- quot )
|
||||||
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
|
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
|
||||||
|
|
||||||
|
! 2cleave
|
||||||
: 2cleave ( x seq -- )
|
: 2cleave ( x seq -- )
|
||||||
[ 2keep ] each 2drop ;
|
[ 2keep ] each 2drop ;
|
||||||
|
|
||||||
: 2cleave>quot ( seq -- quot )
|
: 2cleave>quot ( seq -- quot )
|
||||||
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
|
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
|
||||||
|
|
||||||
|
! 3cleave
|
||||||
: 3cleave ( x seq -- )
|
: 3cleave ( x seq -- )
|
||||||
[ 3keep ] each 3drop ;
|
[ 3keep ] each 3drop ;
|
||||||
|
|
||||||
: 3cleave>quot ( seq -- quot )
|
: 3cleave>quot ( seq -- quot )
|
||||||
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
|
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
|
||||||
|
|
||||||
|
! spread
|
||||||
: spread>quot ( seq -- quot )
|
: spread>quot ( seq -- quot )
|
||||||
[ length [ >r ] <repetition> concat ]
|
[ ] [
|
||||||
[ [ [ r> ] prepend ] map concat ] bi
|
[ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
|
||||||
append [ ] like ;
|
append
|
||||||
|
] reduce ;
|
||||||
|
|
||||||
: spread ( objs... seq -- )
|
: spread ( objs... seq -- )
|
||||||
spread>quot call ;
|
spread>quot call ;
|
||||||
|
|
||||||
|
! cond
|
||||||
ERROR: no-cond ;
|
ERROR: no-cond ;
|
||||||
|
|
||||||
: cond ( assoc -- )
|
: cond ( assoc -- )
|
||||||
|
@ -38,14 +44,23 @@ ERROR: no-cond ;
|
||||||
[ dup callable? [ call ] [ second call ] if ]
|
[ dup callable? [ call ] [ second call ] if ]
|
||||||
[ no-cond ] if* ;
|
[ no-cond ] if* ;
|
||||||
|
|
||||||
|
: alist>quot ( default assoc -- quot )
|
||||||
|
[ rot \ if 3array append [ ] like ] assoc-each ;
|
||||||
|
|
||||||
|
: cond>quot ( assoc -- quot )
|
||||||
|
[ dup callable? [ [ t ] swap 2array ] when ] map
|
||||||
|
reverse [ no-cond ] swap alist>quot ;
|
||||||
|
|
||||||
|
! case
|
||||||
ERROR: no-case ;
|
ERROR: no-case ;
|
||||||
|
|
||||||
: case-find ( obj assoc -- obj' )
|
: case-find ( obj assoc -- obj' )
|
||||||
[
|
[
|
||||||
dup array? [
|
dup array? [
|
||||||
dupd first dup word? [
|
dupd first dup word? [
|
||||||
execute
|
execute
|
||||||
] [
|
] [
|
||||||
dup wrapper? [ wrapped ] when
|
dup wrapper? [ wrapped>> ] when
|
||||||
] if =
|
] if =
|
||||||
] [ quotation? ] if
|
] [ quotation? ] if
|
||||||
] find nip ;
|
] find nip ;
|
||||||
|
@ -57,36 +72,6 @@ ERROR: no-case ;
|
||||||
{ [ dup not ] [ no-case ] }
|
{ [ dup not ] [ no-case ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: with-datastack ( stack quot -- newstack )
|
|
||||||
datastack >r
|
|
||||||
>r >array set-datastack r> call
|
|
||||||
datastack r> swap suffix set-datastack 2nip ; inline
|
|
||||||
|
|
||||||
: recursive-hashcode ( n obj quot -- code )
|
|
||||||
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
|
|
||||||
|
|
||||||
! These go here, not in sequences and hashtables, since those
|
|
||||||
! two depend on combinators
|
|
||||||
M: sequence hashcode*
|
|
||||||
[ sequence-hashcode ] recursive-hashcode ;
|
|
||||||
|
|
||||||
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
|
||||||
|
|
||||||
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
|
||||||
|
|
||||||
M: hashtable hashcode*
|
|
||||||
[
|
|
||||||
dup assoc-size 1 number=
|
|
||||||
[ assoc-hashcode ] [ nip assoc-size ] if
|
|
||||||
] recursive-hashcode ;
|
|
||||||
|
|
||||||
: alist>quot ( default assoc -- quot )
|
|
||||||
[ rot \ if 3array append [ ] like ] assoc-each ;
|
|
||||||
|
|
||||||
: cond>quot ( assoc -- quot )
|
|
||||||
[ dup callable? [ [ t ] swap 2array ] when ] map
|
|
||||||
reverse [ no-cond ] swap alist>quot ;
|
|
||||||
|
|
||||||
: linear-case-quot ( default assoc -- quot )
|
: linear-case-quot ( default assoc -- quot )
|
||||||
[
|
[
|
||||||
[ 1quotation \ dup prefix \ = suffix ]
|
[ 1quotation \ dup prefix \ = suffix ]
|
||||||
|
@ -112,7 +97,7 @@ M: hashtable hashcode*
|
||||||
|
|
||||||
: hash-case-table ( default assoc -- array )
|
: hash-case-table ( default assoc -- array )
|
||||||
V{ } [ 1array ] distribute-buckets
|
V{ } [ 1array ] distribute-buckets
|
||||||
[ linear-case-quot ] with map ;
|
[ [ >r literalize r> ] assoc-map linear-case-quot ] with map ;
|
||||||
|
|
||||||
: hash-dispatch-quot ( table -- quot )
|
: hash-dispatch-quot ( table -- quot )
|
||||||
[ length 1- [ fixnum-bitand ] curry ] keep
|
[ length 1- [ fixnum-bitand ] curry ] keep
|
||||||
|
@ -122,17 +107,14 @@ M: hashtable hashcode*
|
||||||
hash-case-table hash-dispatch-quot
|
hash-case-table hash-dispatch-quot
|
||||||
[ dup hashcode >fixnum ] prepend ;
|
[ dup hashcode >fixnum ] prepend ;
|
||||||
|
|
||||||
: contiguous-range? ( keys -- from to ? )
|
: contiguous-range? ( keys -- ? )
|
||||||
dup [ fixnum? ] all? [
|
dup [ fixnum? ] all? [
|
||||||
dup all-unique? [
|
dup all-unique? [
|
||||||
dup infimum over supremum
|
[ prune length ]
|
||||||
[ - swap prune length + 1 = ] 2keep rot
|
[ [ supremum ] [ infimum ] bi - ]
|
||||||
] [
|
bi - 1 =
|
||||||
drop f f f
|
] [ drop f ] if
|
||||||
] if
|
] [ drop f ] if ;
|
||||||
] [
|
|
||||||
drop f f f
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: dispatch-case ( value from to default array -- )
|
: dispatch-case ( value from to default array -- )
|
||||||
>r >r 3dup between? [
|
>r >r 3dup between? [
|
||||||
|
@ -141,23 +123,41 @@ M: hashtable hashcode*
|
||||||
2drop r> call r> drop
|
2drop r> call r> drop
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: dispatch-case-quot ( default assoc from to -- quot )
|
: dispatch-case-quot ( default assoc -- quot )
|
||||||
-roll -roll sort-keys values [ >quotation ] map
|
[ nip keys [ infimum ] [ supremum ] bi ] 2keep
|
||||||
|
sort-keys values [ >quotation ] map
|
||||||
[ dispatch-case ] 2curry 2curry ;
|
[ dispatch-case ] 2curry 2curry ;
|
||||||
|
|
||||||
: case>quot ( default assoc -- quot )
|
: case>quot ( default assoc -- quot )
|
||||||
dup empty? [
|
dup keys {
|
||||||
drop
|
{ [ dup empty? ] [ 2drop ] }
|
||||||
] [
|
{ [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] }
|
||||||
dup length 4 <=
|
{ [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
|
||||||
over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
|
{ [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] }
|
||||||
[
|
{ [ dup [ wrapper? ] all? ] [ drop [ >r wrapped>> r> ] assoc-map hash-case-quot ] }
|
||||||
linear-case-quot
|
[ drop linear-case-quot ]
|
||||||
] [
|
} cond ;
|
||||||
dup keys contiguous-range? [
|
|
||||||
dispatch-case-quot
|
! with-datastack
|
||||||
] [
|
: with-datastack ( stack quot -- newstack )
|
||||||
2drop hash-case-quot
|
datastack >r
|
||||||
] if
|
>r >array set-datastack r> call
|
||||||
] if
|
datastack r> swap suffix set-datastack 2nip ; inline
|
||||||
] if ;
|
|
||||||
|
! recursive-hashcode
|
||||||
|
: recursive-hashcode ( n obj quot -- code )
|
||||||
|
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
|
||||||
|
|
||||||
|
! These go here, not in sequences and hashtables, since those
|
||||||
|
! two cannot depend on us
|
||||||
|
M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
||||||
|
|
||||||
|
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
||||||
|
|
||||||
|
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
||||||
|
|
||||||
|
M: hashtable hashcode*
|
||||||
|
[
|
||||||
|
dup assoc-size 1 number=
|
||||||
|
[ assoc-hashcode ] [ nip assoc-size ] if
|
||||||
|
] recursive-hashcode ;
|
||||||
|
|
|
@ -26,7 +26,9 @@ ARTICLE: "compiler" "Optimizing compiler"
|
||||||
}
|
}
|
||||||
"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
|
"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
|
||||||
{ $subsection "compiler-usage" }
|
{ $subsection "compiler-usage" }
|
||||||
{ $subsection "compiler-errors" } ;
|
{ $subsection "compiler-errors" }
|
||||||
|
{ $subsection "optimizer" }
|
||||||
|
{ $subsection "generator" } ;
|
||||||
|
|
||||||
ABOUT: "compiler"
|
ABOUT: "compiler"
|
||||||
|
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
USING: arrays compiler.units kernel kernel.private math
|
USING: accessors arrays compiler.units kernel kernel.private math
|
||||||
math.constants math.private sequences strings tools.test words
|
math.constants math.private sequences strings tools.test words
|
||||||
continuations sequences.private hashtables.private byte-arrays
|
continuations sequences.private hashtables.private byte-arrays
|
||||||
strings.private system random layouts vectors.private
|
strings.private system random layouts vectors
|
||||||
sbufs.private strings.private slots.private alien math.order
|
sbufs strings.private slots.private alien math.order
|
||||||
alien.accessors alien.c-types alien.syntax alien.strings
|
alien.accessors alien.c-types alien.syntax alien.strings
|
||||||
namespaces libc sequences.private io.encodings.ascii ;
|
namespaces libc sequences.private io.encodings.ascii ;
|
||||||
IN: compiler.tests
|
IN: compiler.tests
|
||||||
|
@ -332,11 +332,11 @@ cell 8 = [
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ V{ 1 2 } ] [
|
[ V{ 1 2 } ] [
|
||||||
{ 1 2 3 } 2 [ array>vector ] compile-call
|
{ 1 2 3 } 2 [ vector boa ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ SBUF" hello" ] [
|
[ SBUF" hello" ] [
|
||||||
"hello world" 5 [ string>sbuf ] compile-call
|
"hello world" 5 [ sbuf boa ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ [ 3 + ] ] [
|
[ [ 3 + ] ] [
|
||||||
|
@ -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
|
[ 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
|
[ -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
|
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
|
||||||
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
|
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests
|
||||||
USING: compiler compiler.units tools.test math parser kernel
|
USING: accessors compiler compiler.units tools.test math parser
|
||||||
sequences sequences.private classes.mixin generic definitions
|
kernel sequences sequences.private classes.mixin generic
|
||||||
arrays words assocs ;
|
definitions arrays words assocs ;
|
||||||
|
|
||||||
GENERIC: method-redefine-test ( a -- b )
|
GENERIC: method-redefine-test ( a -- b )
|
||||||
|
|
||||||
|
@ -23,13 +23,13 @@ M: integer method-redefine-test 3 + ;
|
||||||
: hey ( -- ) ;
|
: hey ( -- ) ;
|
||||||
: there ( -- ) hey ;
|
: there ( -- ) hey ;
|
||||||
|
|
||||||
[ t ] [ \ hey compiled? ] unit-test
|
[ t ] [ \ hey compiled>> ] unit-test
|
||||||
[ t ] [ \ there compiled? ] unit-test
|
[ t ] [ \ there compiled>> ] unit-test
|
||||||
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
|
||||||
[ f ] [ \ hey compiled? ] unit-test
|
[ f ] [ \ hey compiled>> ] unit-test
|
||||||
[ f ] [ \ there compiled? ] unit-test
|
[ f ] [ \ there compiled>> ] unit-test
|
||||||
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] 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
|
! Just changing the stack effect didn't mark a word for recompilation
|
||||||
DEFER: change-effect
|
DEFER: change-effect
|
||||||
|
@ -44,24 +44,24 @@ DEFER: change-effect
|
||||||
: bad ( -- ) good ;
|
: bad ( -- ) good ;
|
||||||
: ugly ( -- ) bad ;
|
: ugly ( -- ) bad ;
|
||||||
|
|
||||||
[ t ] [ \ good compiled? ] unit-test
|
[ t ] [ \ good compiled>> ] unit-test
|
||||||
[ t ] [ \ bad compiled? ] unit-test
|
[ t ] [ \ bad compiled>> ] unit-test
|
||||||
[ t ] [ \ ugly compiled? ] unit-test
|
[ t ] [ \ ugly compiled>> ] unit-test
|
||||||
|
|
||||||
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
|
||||||
|
|
||||||
[ f ] [ \ good compiled? ] unit-test
|
[ f ] [ \ good compiled>> ] unit-test
|
||||||
[ f ] [ \ bad compiled? ] unit-test
|
[ f ] [ \ bad compiled>> ] unit-test
|
||||||
[ f ] [ \ ugly compiled? ] unit-test
|
[ f ] [ \ ugly compiled>> ] unit-test
|
||||||
|
|
||||||
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
|
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
|
||||||
|
|
||||||
[ t ] [ \ good compiled? ] unit-test
|
[ t ] [ \ good compiled>> ] unit-test
|
||||||
[ t ] [ \ bad compiled? ] unit-test
|
[ t ] [ \ bad compiled>> ] unit-test
|
||||||
[ t ] [ \ ugly compiled? ] unit-test
|
[ t ] [ \ ugly compiled>> ] unit-test
|
||||||
|
|
||||||
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: compiler.tests
|
IN: compiler.tests
|
||||||
USING: compiler compiler.units tools.test math parser kernel
|
USING: accessors compiler compiler.units tools.test math parser
|
||||||
sequences sequences.private classes.mixin generic definitions
|
kernel sequences sequences.private classes.mixin generic
|
||||||
arrays words assocs ;
|
definitions arrays words assocs ;
|
||||||
|
|
||||||
GENERIC: sheeple ( obj -- x )
|
GENERIC: sheeple ( obj -- x )
|
||||||
|
|
||||||
|
@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
|
||||||
: sheeple-test ( -- string ) { } sheeple ;
|
: sheeple-test ( -- string ) { } sheeple ;
|
||||||
|
|
||||||
[ "sheeple" ] [ sheeple-test ] 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
|
[ 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
|
[ 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
|
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||||
|
|
||||||
[ "sheeple" ] [ sheeple-test ] 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
|
[ 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
|
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||||
|
|
|
@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
||||||
10 [
|
10 [
|
||||||
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
||||||
[ t ] [
|
[ t ] [
|
||||||
"USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
|
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
|
||||||
] unit-test
|
] unit-test
|
||||||
] times
|
] times
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
! Black box testing of templating optimization
|
! Black box testing of templating optimization
|
||||||
USING: arrays compiler kernel kernel.private math
|
USING: accessors arrays compiler kernel kernel.private math
|
||||||
hashtables.private math.private namespaces sequences
|
hashtables.private math.private namespaces sequences
|
||||||
sequences.private tools.test namespaces.private slots.private
|
sequences.private tools.test namespaces.private slots.private
|
||||||
sequences.private byte-arrays alien alien.accessors layouts
|
sequences.private byte-arrays alien alien.accessors layouts
|
||||||
|
@ -138,7 +138,7 @@ unit-test
|
||||||
0 swap hellish-bug-2 drop ;
|
0 swap hellish-bug-2 drop ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
H{ { 1 2 } { 3 4 } } dup hash-array
|
H{ { 1 2 } { 3 4 } } dup array>>
|
||||||
[ 0 swap hellish-bug-2 drop ] compile-call
|
[ 0 swap hellish-bug-2 drop ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -245,13 +245,13 @@ TUPLE: my-tuple ;
|
||||||
[ dup float+ ]
|
[ dup float+ ]
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
[ t ] [ \ float-spill-bug compiled? ] unit-test
|
[ t ] [ \ float-spill-bug compiled>> ] unit-test
|
||||||
|
|
||||||
! Regression
|
! Regression
|
||||||
: dispatch-alignment-regression ( -- c )
|
: dispatch-alignment-regression ( -- c )
|
||||||
{ tuple vector } 3 slot { word } declare
|
{ tuple vector } 3 slot { word } declare
|
||||||
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
|
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
|
[ vector ] [ dispatch-alignment-regression ] unit-test
|
||||||
|
|
|
@ -6,19 +6,5 @@ TUPLE: color red green blue ;
|
||||||
[ T{ color f 1 2 3 } ]
|
[ T{ color f 1 2 3 } ]
|
||||||
[ 1 2 3 [ color boa ] compile-call ] unit-test
|
[ 1 2 3 [ color boa ] compile-call ] unit-test
|
||||||
|
|
||||||
[ 1 3 ] [
|
|
||||||
1 2 3 color boa
|
|
||||||
[ { color-red color-blue } get-slots ] compile-call
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ T{ color f 10 2 20 } ] [
|
|
||||||
10 20
|
|
||||||
1 2 3 color boa [
|
|
||||||
[
|
|
||||||
{ set-color-red set-color-blue } set-slots
|
|
||||||
] compile-call
|
|
||||||
] keep
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ T{ color f f f f } ]
|
[ T{ color f f f f } ]
|
||||||
[ [ color new ] compile-call ] unit-test
|
[ [ color new ] compile-call ] unit-test
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel continuations assocs namespaces sequences words
|
USING: accessors kernel continuations assocs namespaces
|
||||||
vocabs definitions hashtables init sets ;
|
sequences words vocabs definitions hashtables init sets ;
|
||||||
IN: compiler.units
|
IN: compiler.units
|
||||||
|
|
||||||
SYMBOL: old-definitions
|
SYMBOL: old-definitions
|
||||||
|
@ -54,7 +54,7 @@ GENERIC: definitions-changed ( assoc obj -- )
|
||||||
|
|
||||||
: changed-vocabs ( assoc -- vocabs )
|
: changed-vocabs ( assoc -- vocabs )
|
||||||
[ drop word? ] assoc-filter
|
[ drop word? ] assoc-filter
|
||||||
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
|
[ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
|
||||||
|
|
||||||
: updated-definitions ( -- assoc )
|
: updated-definitions ( -- assoc )
|
||||||
H{ } clone
|
H{ } clone
|
||||||
|
|
|
@ -66,7 +66,7 @@ IN: continuations.tests
|
||||||
|
|
||||||
[ 1 3 2 ] [ bar ] unit-test
|
[ 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
|
[ 1 ] [ "c" get innermost-frame-scan ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays generic kernel kernel.private math memory
|
USING: arrays generic kernel kernel.private math memory
|
||||||
namespaces sequences layouts system hashtables classes alien
|
namespaces sequences layouts system hashtables classes alien
|
||||||
byte-arrays bit-arrays float-arrays combinators words sets ;
|
byte-arrays combinators words sets ;
|
||||||
IN: cpu.architecture
|
IN: cpu.architecture
|
||||||
|
|
||||||
! Register classes
|
! Register classes
|
||||||
|
|
|
@ -8,7 +8,7 @@ generator generator.registers generator.fixup sequences.private
|
||||||
sbufs vectors system layouts math.floats.private
|
sbufs vectors system layouts math.floats.private
|
||||||
classes classes.tuple classes.tuple.private sbufs.private
|
classes classes.tuple classes.tuple.private sbufs.private
|
||||||
vectors.private strings.private slots.private combinators
|
vectors.private strings.private slots.private combinators
|
||||||
bit-arrays float-arrays compiler.constants ;
|
compiler.constants ;
|
||||||
IN: cpu.ppc.intrinsics
|
IN: cpu.ppc.intrinsics
|
||||||
|
|
||||||
: %slot-literal-known-tag
|
: %slot-literal-known-tag
|
||||||
|
@ -437,14 +437,11 @@ IN: cpu.ppc.intrinsics
|
||||||
{ +clobber+ { "n" } }
|
{ +clobber+ { "n" } }
|
||||||
} define-intrinsic
|
} define-intrinsic
|
||||||
|
|
||||||
\ <tuple> [
|
\ (tuple) [
|
||||||
tuple "layout" get layout-size 2 + cells %allot
|
tuple "layout" get size>> 2 + cells %allot
|
||||||
! Store layout
|
! Store layout
|
||||||
"layout" get 12 load-indirect
|
"layout" get 12 load-indirect
|
||||||
12 11 cell STW
|
12 11 cell STW
|
||||||
! Zero out the rest of the tuple
|
|
||||||
f v>operand 12 LI
|
|
||||||
"layout" get layout-size [ 12 11 rot 2 + cells STW ] each
|
|
||||||
! Store tagged ptr in reg
|
! Store tagged ptr in reg
|
||||||
"tuple" get tuple %store-tagged
|
"tuple" get tuple %store-tagged
|
||||||
] H{
|
] H{
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2005, 2007 Slava Pestov.
|
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types arrays cpu.x86.assembler
|
USING: accessors alien.c-types arrays cpu.x86.assembler
|
||||||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
||||||
cpu.x86.allot cpu.architecture kernel kernel.private math
|
cpu.x86.allot cpu.architecture kernel kernel.private math
|
||||||
namespaces sequences generator.registers generator.fixup system
|
namespaces sequences generator.registers generator.fixup system
|
||||||
|
@ -178,7 +178,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
|
||||||
|
|
||||||
: struct-types&offset ( struct-type -- pairs )
|
: struct-types&offset ( struct-type -- pairs )
|
||||||
struct-type-fields [
|
struct-type-fields [
|
||||||
dup slot-spec-type swap slot-spec-offset 2array
|
[ type>> ] [ offset>> ] bi 2array
|
||||||
] map ;
|
] map ;
|
||||||
|
|
||||||
: split-struct ( pairs -- seq )
|
: split-struct ( pairs -- seq )
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
|
||||||
kernel.private math math.private namespaces quotations sequences
|
kernel.private math math.private namespaces quotations sequences
|
||||||
words generic byte-arrays hashtables hashtables.private
|
words generic byte-arrays hashtables hashtables.private
|
||||||
|
@ -289,15 +289,11 @@ IN: cpu.x86.intrinsics
|
||||||
{ +clobber+ { "n" } }
|
{ +clobber+ { "n" } }
|
||||||
} define-intrinsic
|
} define-intrinsic
|
||||||
|
|
||||||
\ <tuple> [
|
\ (tuple) [
|
||||||
tuple "layout" get layout-size 2 + cells [
|
tuple "layout" get size>> 2 + cells [
|
||||||
! Store layout
|
! Store layout
|
||||||
"layout" get "scratch" get load-literal
|
"layout" get "scratch" get load-literal
|
||||||
1 object@ "scratch" operand MOV
|
1 object@ "scratch" operand MOV
|
||||||
! Zero out the rest of the tuple
|
|
||||||
"layout" get layout-size [
|
|
||||||
2 + object@ f v>operand MOV
|
|
||||||
] each
|
|
||||||
! Store tagged ptr in reg
|
! Store tagged ptr in reg
|
||||||
"tuple" get tuple %store-tagged
|
"tuple" get tuple %store-tagged
|
||||||
] %allot
|
] %allot
|
||||||
|
|
|
@ -1,13 +1,13 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays definitions generic hashtables inspector io kernel
|
USING: slots arrays definitions generic hashtables summary io
|
||||||
math namespaces prettyprint prettyprint.config sequences assocs
|
kernel math namespaces prettyprint prettyprint.config sequences
|
||||||
sequences.private strings io.styles vectors words system
|
assocs sequences.private strings io.styles vectors words system
|
||||||
splitting math.parser classes.tuple continuations
|
splitting math.parser classes.tuple continuations
|
||||||
continuations.private combinators generic.math
|
continuations.private combinators generic.math classes.builtin
|
||||||
classes.builtin classes compiler.units generic.standard vocabs
|
classes compiler.units generic.standard vocabs threads
|
||||||
threads threads.private init kernel.private libc io.encodings
|
threads.private init kernel.private libc io.encodings
|
||||||
mirrors accessors math.order destructors ;
|
accessors math.order destructors ;
|
||||||
IN: debugger
|
IN: debugger
|
||||||
|
|
||||||
GENERIC: error. ( error -- )
|
GENERIC: error. ( error -- )
|
||||||
|
@ -16,7 +16,6 @@ GENERIC: error-help ( error -- topic )
|
||||||
M: object error. . ;
|
M: object error. . ;
|
||||||
M: object error-help drop f ;
|
M: object error-help drop f ;
|
||||||
|
|
||||||
M: tuple error. describe ;
|
|
||||||
M: tuple error-help class ;
|
M: tuple error-help class ;
|
||||||
|
|
||||||
M: string error. print ;
|
M: string error. print ;
|
||||||
|
@ -33,9 +32,6 @@ M: string error. print ;
|
||||||
: :get ( variable -- value )
|
: :get ( variable -- value )
|
||||||
error-continuation get continuation-name assoc-stack ;
|
error-continuation get continuation-name assoc-stack ;
|
||||||
|
|
||||||
: :vars ( -- )
|
|
||||||
error-continuation get continuation-name namestack. ;
|
|
||||||
|
|
||||||
: :res ( n -- * )
|
: :res ( n -- * )
|
||||||
1- restarts get-global nth f restarts set-global restart ;
|
1- restarts get-global nth f restarts set-global restart ;
|
||||||
|
|
||||||
|
@ -190,12 +186,13 @@ M: no-method summary
|
||||||
|
|
||||||
M: no-method error.
|
M: no-method error.
|
||||||
"Generic word " write
|
"Generic word " write
|
||||||
dup no-method-generic pprint
|
dup generic>> pprint
|
||||||
" does not define a method for the " write
|
" does not define a method for the " write
|
||||||
dup no-method-object class pprint
|
dup object>> class pprint
|
||||||
" class." print
|
" class." print
|
||||||
"Allowed classes: " write dup no-method-generic order .
|
"Dispatching on object: " write object>> short. ;
|
||||||
"Dispatching on object: " write no-method-object short. ;
|
|
||||||
|
M: bad-slot-value summary drop "Bad store to specialized slot" ;
|
||||||
|
|
||||||
M: no-math-method summary
|
M: no-math-method summary
|
||||||
drop "No suitable arithmetic method" ;
|
drop "No suitable arithmetic method" ;
|
||||||
|
@ -212,9 +209,6 @@ M: check-method summary
|
||||||
M: not-a-tuple summary
|
M: not-a-tuple summary
|
||||||
drop "Not a tuple" ;
|
drop "Not a tuple" ;
|
||||||
|
|
||||||
M: not-a-tuple-class summary
|
|
||||||
drop "Not a tuple class" ;
|
|
||||||
|
|
||||||
M: bad-superclass summary
|
M: bad-superclass summary
|
||||||
drop "Tuple classes can only inherit from other tuple classes" ;
|
drop "Tuple classes can only inherit from other tuple classes" ;
|
||||||
|
|
||||||
|
@ -295,10 +289,6 @@ M: encode-error summary drop "Character encoding error" ;
|
||||||
|
|
||||||
M: decode-error summary drop "Character decoding error" ;
|
M: decode-error summary drop "Character decoding error" ;
|
||||||
|
|
||||||
M: no-such-slot summary drop "No such slot" ;
|
|
||||||
|
|
||||||
M: immutable-slot summary drop "Slot is immutable" ;
|
|
||||||
|
|
||||||
M: bad-create summary drop "Bad parameters to create" ;
|
M: bad-create summary drop "Bad parameters to create" ;
|
||||||
|
|
||||||
M: attempt-all-error summary drop "Nothing to attempt" ;
|
M: attempt-all-error summary drop "Nothing to attempt" ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
|
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
|
||||||
! Slava Pestov.
|
! Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: combinators kernel math sequences accessors inspector
|
USING: combinators kernel math sequences accessors summary
|
||||||
dequeues ;
|
dequeues ;
|
||||||
IN: dlists
|
IN: dlists
|
||||||
|
|
||||||
|
|
|
@ -24,7 +24,7 @@ TUPLE: effect in out terminated? ;
|
||||||
|
|
||||||
GENERIC: (stack-picture) ( obj -- str )
|
GENERIC: (stack-picture) ( obj -- str )
|
||||||
M: string (stack-picture) ;
|
M: string (stack-picture) ;
|
||||||
M: word (stack-picture) word-name ;
|
M: word (stack-picture) name>> ;
|
||||||
M: integer (stack-picture) drop "object" ;
|
M: integer (stack-picture) drop "object" ;
|
||||||
|
|
||||||
: stack-picture ( seq -- string )
|
: stack-picture ( seq -- string )
|
||||||
|
@ -46,7 +46,7 @@ M: symbol stack-effect drop (( -- symbol )) ;
|
||||||
|
|
||||||
M: word stack-effect
|
M: word stack-effect
|
||||||
{ "declared-effect" "inferred-effect" }
|
{ "declared-effect" "inferred-effect" }
|
||||||
swap word-props [ at ] curry map [ ] find nip ;
|
swap props>> [ at ] curry map [ ] find nip ;
|
||||||
|
|
||||||
M: effect clone
|
M: effect clone
|
||||||
[ in>> clone ] [ out>> clone ] bi <effect> ;
|
[ in>> clone ] [ out>> clone ] bi <effect> ;
|
||||||
|
|
|
@ -1,10 +0,0 @@
|
||||||
IN: float-arrays.tests
|
|
||||||
USING: float-arrays tools.test ;
|
|
||||||
|
|
||||||
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
|
|
||||||
|
|
||||||
[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize-float-array ] unit-test
|
|
||||||
|
|
||||||
[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
|
|
||||||
|
|
||||||
[ -10 F{ } resize-float-array ] must-fail
|
|
|
@ -1,43 +0,0 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: kernel kernel.private alien.accessors sequences
|
|
||||||
sequences.private math math.private ;
|
|
||||||
IN: float-arrays
|
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
: float-array@ swap >fixnum 8 fixnum*fast ; inline
|
|
||||||
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
M: float-array clone (clone) ;
|
|
||||||
M: float-array length array-capacity ;
|
|
||||||
|
|
||||||
M: float-array nth-unsafe
|
|
||||||
float-array@ alien-double ;
|
|
||||||
|
|
||||||
M: float-array set-nth-unsafe
|
|
||||||
>r >r >float r> r> float-array@ set-alien-double ;
|
|
||||||
|
|
||||||
: >float-array ( seq -- float-array ) F{ } clone-like ; inline
|
|
||||||
|
|
||||||
M: float-array like
|
|
||||||
drop dup float-array? [ >float-array ] unless ;
|
|
||||||
|
|
||||||
M: float-array new-sequence drop 0.0 <float-array> ;
|
|
||||||
|
|
||||||
M: float-array equal?
|
|
||||||
over float-array? [ sequence= ] [ 2drop f ] if ;
|
|
||||||
|
|
||||||
M: float-array resize
|
|
||||||
resize-float-array ;
|
|
||||||
|
|
||||||
INSTANCE: float-array sequence
|
|
||||||
|
|
||||||
: 1float-array ( x -- array ) 1 swap <float-array> ; flushable
|
|
||||||
|
|
||||||
: 2float-array ( x y -- array ) F{ } 2sequence ; flushable
|
|
||||||
|
|
||||||
: 3float-array ( x y z -- array ) F{ } 3sequence ; flushable
|
|
||||||
|
|
||||||
: 4float-array ( w x y z -- array ) F{ } 4sequence ; flushable
|
|
|
@ -88,7 +88,7 @@ TUPLE: rel-fixup arg class type ;
|
||||||
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
|
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
|
||||||
|
|
||||||
: push-4 ( value vector -- )
|
: 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 ;
|
swap set-alien-unsigned-4 ;
|
||||||
|
|
||||||
M: rel-fixup fixup*
|
M: rel-fixup fixup*
|
||||||
|
@ -120,7 +120,7 @@ SYMBOL: literal-table
|
||||||
>r add-literal r> rt-xt rel-fixup ;
|
>r add-literal r> rt-xt rel-fixup ;
|
||||||
|
|
||||||
: rel-primitive ( word class -- )
|
: 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 -- )
|
: rel-literal ( literal class -- )
|
||||||
>r add-literal r> rt-literal rel-fixup ;
|
>r add-literal r> rt-literal rel-fixup ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
effects generator.fixup generator.registers generic hashtables
|
||||||
inference inference.backend inference.dataflow io kernel
|
inference inference.backend inference.dataflow io kernel
|
||||||
kernel.private layouts math namespaces optimizer
|
kernel.private layouts math namespaces optimizer
|
||||||
|
@ -20,7 +20,7 @@ SYMBOL: compiled
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: maybe-compile ( word -- )
|
: maybe-compile ( word -- )
|
||||||
dup compiled? [ drop ] [ queue-compile ] if ;
|
dup compiled>> [ drop ] [ queue-compile ] if ;
|
||||||
|
|
||||||
SYMBOL: compiling-word
|
SYMBOL: compiling-word
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: arrays assocs classes classes.private classes.algebra
|
USING: arrays assocs classes classes.private classes.algebra
|
||||||
combinators cpu.architecture generator.fixup hashtables kernel
|
combinators cpu.architecture generator.fixup hashtables kernel
|
||||||
layouts math namespaces quotations sequences system vectors
|
layouts math namespaces quotations sequences system vectors
|
||||||
words effects alien byte-arrays bit-arrays float-arrays
|
words effects alien byte-arrays
|
||||||
accessors sets math.order ;
|
accessors sets math.order ;
|
||||||
IN: generator.registers
|
IN: generator.registers
|
||||||
|
|
||||||
|
@ -184,8 +184,6 @@ INSTANCE: constant value
|
||||||
{ [ dup \ f class<= ] [ drop %unbox-f ] }
|
{ [ dup \ f class<= ] [ drop %unbox-f ] }
|
||||||
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
|
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
|
||||||
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
|
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
|
||||||
{ [ dup bit-array class<= ] [ drop %unbox-byte-array ] }
|
|
||||||
{ [ dup float-array class<= ] [ drop %unbox-byte-array ] }
|
|
||||||
[ drop %unbox-any-c-ptr ]
|
[ drop %unbox-any-c-ptr ]
|
||||||
} cond ; inline
|
} cond ; inline
|
||||||
|
|
||||||
|
@ -195,7 +193,9 @@ INSTANCE: constant value
|
||||||
#! temp then temp to the destination.
|
#! temp then temp to the destination.
|
||||||
temp-reg over %move
|
temp-reg over %move
|
||||||
operand-class temp-reg
|
operand-class temp-reg
|
||||||
{ set-operand-class set-tagged-vreg } tagged construct
|
tagged new
|
||||||
|
swap >>vreg
|
||||||
|
swap >>class
|
||||||
%move ;
|
%move ;
|
||||||
|
|
||||||
: %move ( dst src -- )
|
: %move ( dst src -- )
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: alien arrays definitions generic generic.standard
|
USING: accessors alien arrays definitions generic generic.standard
|
||||||
generic.math assocs hashtables io kernel math namespaces parser
|
generic.math assocs hashtables io kernel math namespaces parser
|
||||||
prettyprint sequences strings tools.test vectors words
|
prettyprint sequences strings tools.test vectors words
|
||||||
quotations classes classes.algebra continuations layouts
|
quotations classes classes.algebra continuations layouts
|
||||||
|
@ -144,7 +144,7 @@ M: integer generic-forget-test-1 / ;
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
\ / usage [ word? ] filter
|
\ / usage [ word? ] filter
|
||||||
[ word-name "generic-forget-test-1/integer" = ] contains?
|
[ name>> "integer=>generic-forget-test-1" = ] contains?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -153,7 +153,7 @@ M: integer generic-forget-test-1 / ;
|
||||||
|
|
||||||
[ f ] [
|
[ f ] [
|
||||||
\ / usage [ word? ] filter
|
\ / usage [ word? ] filter
|
||||||
[ word-name "generic-forget-test-1/integer" = ] contains?
|
[ name>> "integer=>generic-forget-test-1" = ] contains?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
GENERIC: generic-forget-test-2 ( a b -- c )
|
GENERIC: generic-forget-test-2 ( a b -- c )
|
||||||
|
@ -162,7 +162,7 @@ M: sequence generic-forget-test-2 = ;
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
\ = usage [ word? ] filter
|
\ = usage [ word? ] filter
|
||||||
[ word-name "generic-forget-test-2/sequence" = ] contains?
|
[ name>> "sequence=>generic-forget-test-2" = ] contains?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
@ -171,7 +171,7 @@ M: sequence generic-forget-test-2 = ;
|
||||||
|
|
||||||
[ f ] [
|
[ f ] [
|
||||||
\ = usage [ word? ] filter
|
\ = usage [ word? ] filter
|
||||||
[ word-name "generic-forget-test-2/sequence" = ] contains?
|
[ name>> "sequence=>generic-forget-test-2" = ] contains?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
GENERIC: generic-forget-test-3 ( a -- b )
|
GENERIC: generic-forget-test-3 ( a -- b )
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: words kernel sequences namespaces assocs hashtables
|
USING: accessors words kernel sequences namespaces assocs
|
||||||
definitions kernel.private classes classes.private
|
hashtables definitions kernel.private classes classes.private
|
||||||
classes.algebra quotations arrays vocabs effects combinators
|
classes.algebra quotations arrays vocabs effects combinators
|
||||||
sets ;
|
sets ;
|
||||||
IN: generic
|
IN: generic
|
||||||
|
@ -30,10 +30,10 @@ PREDICATE: method-spec < pair
|
||||||
: order ( generic -- seq )
|
: order ( generic -- seq )
|
||||||
"methods" word-prop keys sort-classes ;
|
"methods" word-prop keys sort-classes ;
|
||||||
|
|
||||||
: specific-method ( class word -- class )
|
: specific-method ( class generic -- method/f )
|
||||||
order min-class ;
|
tuck order min-class dup [ swap method ] [ 2drop f ] if ;
|
||||||
|
|
||||||
GENERIC: effective-method ( ... generic -- method )
|
GENERIC: effective-method ( generic -- method )
|
||||||
|
|
||||||
: next-method-class ( class generic -- class/f )
|
: next-method-class ( class generic -- class/f )
|
||||||
order [ class<= ] with filter reverse dup length 1 =
|
order [ class<= ] with filter reverse dup length 1 =
|
||||||
|
@ -42,7 +42,7 @@ GENERIC: effective-method ( ... generic -- method )
|
||||||
: next-method ( class generic -- class/f )
|
: next-method ( class generic -- class/f )
|
||||||
[ next-method-class ] keep method ;
|
[ next-method-class ] keep method ;
|
||||||
|
|
||||||
GENERIC: next-method-quot* ( class generic -- quot )
|
GENERIC: next-method-quot* ( class generic combination -- quot )
|
||||||
|
|
||||||
: next-method-quot ( class generic -- quot )
|
: next-method-quot ( class generic -- quot )
|
||||||
dup "combination" word-prop next-method-quot* ;
|
dup "combination" word-prop next-method-quot* ;
|
||||||
|
@ -72,7 +72,7 @@ TUPLE: check-method class generic ;
|
||||||
3tri ; inline
|
3tri ; inline
|
||||||
|
|
||||||
: method-word-name ( class word -- string )
|
: method-word-name ( class word -- string )
|
||||||
word-name "/" rot word-name 3append ;
|
[ name>> ] bi@ "=>" swap 3append ;
|
||||||
|
|
||||||
PREDICATE: method-body < word
|
PREDICATE: method-body < word
|
||||||
"method-generic" word-prop >boolean ;
|
"method-generic" word-prop >boolean ;
|
||||||
|
@ -93,7 +93,7 @@ M: method-body crossref?
|
||||||
check-method
|
check-method
|
||||||
[ method-word-props ] 2keep
|
[ method-word-props ] 2keep
|
||||||
method-word-name f <word>
|
method-word-name f <word>
|
||||||
[ set-word-props ] keep ;
|
swap >>props ;
|
||||||
|
|
||||||
: with-implementors ( class generic quot -- )
|
: with-implementors ( class generic quot -- )
|
||||||
[ swap implementors-map get at ] dip call ; inline
|
[ swap implementors-map get at ] dip call ; inline
|
||||||
|
|
|
@ -15,7 +15,7 @@ HELP: no-math-method
|
||||||
HELP: math-method
|
HELP: math-method
|
||||||
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
|
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
|
||||||
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
|
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
|
||||||
{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip +/float ]" } } ;
|
{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float=>+ ]" } } ;
|
||||||
|
|
||||||
HELP: math-class
|
HELP: math-class
|
||||||
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
|
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser kernel words generic namespaces inspector ;
|
USING: parser kernel words generic namespaces summary ;
|
||||||
IN: generic.parser
|
IN: generic.parser
|
||||||
|
|
||||||
ERROR: not-in-a-method-error ;
|
ERROR: not-in-a-method-error ;
|
||||||
|
|
|
@ -18,7 +18,7 @@ C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
|
||||||
TUPLE: tuple-dispatch-engine echelons ;
|
TUPLE: tuple-dispatch-engine echelons ;
|
||||||
|
|
||||||
: push-echelon ( class method assoc -- )
|
: 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 ;
|
[ ?set-at ] change-at ;
|
||||||
|
|
||||||
: echelon-sort ( assoc -- assoc' )
|
: echelon-sort ( assoc -- assoc' )
|
||||||
|
@ -54,7 +54,7 @@ M: trivial-tuple-dispatch-engine engine>quot
|
||||||
] [ ] make ;
|
] [ ] make ;
|
||||||
|
|
||||||
: engine-word-name ( -- string )
|
: engine-word-name ( -- string )
|
||||||
generic get word-name "/tuple-dispatch-engine" append ;
|
generic get name>> "/tuple-dispatch-engine" append ;
|
||||||
|
|
||||||
PREDICATE: engine-word < word
|
PREDICATE: engine-word < word
|
||||||
"tuple-dispatch-generic" word-prop generic? ;
|
"tuple-dispatch-generic" word-prop generic? ;
|
||||||
|
|
|
@ -287,7 +287,7 @@ M: sbuf no-stack-effect-decl ;
|
||||||
|
|
||||||
[ ] [ \ no-stack-effect-decl see ] unit-test
|
[ ] [ \ 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
|
! Cross-referencing with generic words
|
||||||
TUPLE: xref-tuple-1 ;
|
TUPLE: xref-tuple-1 ;
|
||||||
|
|
|
@ -93,11 +93,11 @@ ERROR: no-next-method class generic ;
|
||||||
|
|
||||||
: single-next-method-quot ( class generic -- quot )
|
: single-next-method-quot ( class generic -- quot )
|
||||||
[
|
[
|
||||||
[ drop [ instance? ] curry % ]
|
[ drop "predicate" word-prop % ]
|
||||||
[
|
[
|
||||||
2dup next-method
|
2dup next-method
|
||||||
[ 2nip 1quotation ]
|
[ 2nip 1quotation ]
|
||||||
[ [ no-next-method ] 2curry ] if* ,
|
[ [ no-next-method ] 2curry [ ] like ] if* ,
|
||||||
]
|
]
|
||||||
[ [ inconsistent-next-method ] 2curry , ]
|
[ [ inconsistent-next-method ] 2curry , ]
|
||||||
2tri
|
2tri
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: kernel math math.order strings arrays vectors sequences
|
||||||
accessors ;
|
accessors ;
|
||||||
IN: grouping
|
IN: grouping
|
||||||
|
|
||||||
TUPLE: abstract-groups seq n ;
|
TUPLE: abstract-groups { seq read-only } { n read-only } ;
|
||||||
|
|
||||||
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
|
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
|
||||||
|
|
||||||
|
|
|
@ -7,31 +7,17 @@ ARTICLE: "growable" "Resizable sequence implementation"
|
||||||
$nl
|
$nl
|
||||||
"There is a resizable sequence mixin:"
|
"There is a resizable sequence mixin:"
|
||||||
{ $subsection growable }
|
{ $subsection growable }
|
||||||
"This mixin implements the sequence protocol in terms of a growable protocol:"
|
"This mixin implements the sequence protocol by assuming the object has two specific slots:"
|
||||||
{ $subsection underlying }
|
{ $list
|
||||||
{ $subsection set-underlying }
|
{ { $snippet "length" } " - the fill pointer (number of occupied elements in the underlying storage)" }
|
||||||
{ $subsection set-fill }
|
{ { $snippet "underlying" } " - the underlying storage" }
|
||||||
|
}
|
||||||
"The underlying sequence must implement a generic word:"
|
"The underlying sequence must implement a generic word:"
|
||||||
{ $subsection resize }
|
{ $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"
|
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
|
HELP: capacity
|
||||||
{ $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } }
|
{ $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." } ;
|
{ $description "Outputs the number of elements the sequence can hold without growing." } ;
|
||||||
|
|
|
@ -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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
|
||||||
! Some low-level code used by vectors and string buffers.
|
! 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 ;
|
sequences sequences.private ;
|
||||||
IN: growable
|
IN: growable
|
||||||
|
|
||||||
MIXIN: 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 -- )
|
: expand ( len seq -- )
|
||||||
[ underlying resize ] keep set-underlying ; inline
|
[ resize ] change-underlying drop ; inline
|
||||||
|
|
||||||
: contract ( len seq -- )
|
: contract ( len seq -- )
|
||||||
[ length ] keep
|
[ length ] keep
|
||||||
|
@ -35,7 +35,7 @@ M: growable set-length ( n seq -- )
|
||||||
] [
|
] [
|
||||||
2dup capacity > [ 2dup expand ] when
|
2dup capacity > [ 2dup expand ] when
|
||||||
] if
|
] if
|
||||||
>r >fixnum r> set-fill ;
|
(>>length) ;
|
||||||
|
|
||||||
: new-size ( old -- new ) 1+ 3 * ; inline
|
: new-size ( old -- new ) 1+ 3 * ; inline
|
||||||
|
|
||||||
|
@ -44,20 +44,19 @@ M: growable set-length ( n seq -- )
|
||||||
2dup length >= [
|
2dup length >= [
|
||||||
2dup capacity >= [ over new-size over expand ] when
|
2dup capacity >= [ over new-size over expand ] when
|
||||||
>r >fixnum r>
|
>r >fixnum r>
|
||||||
2dup >r 1 fixnum+fast r> set-fill
|
over 1 fixnum+fast over (>>length)
|
||||||
] [
|
] [
|
||||||
>r >fixnum r>
|
>r >fixnum r>
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
M: growable set-nth ensure set-nth-unsafe ;
|
M: growable set-nth ensure set-nth-unsafe ;
|
||||||
|
|
||||||
M: growable clone ( seq -- newseq )
|
M: growable clone (clone) [ clone ] change-underlying ;
|
||||||
(clone) dup underlying clone over set-underlying ;
|
|
||||||
|
|
||||||
M: growable lengthen ( n seq -- )
|
M: growable lengthen ( n seq -- )
|
||||||
2dup length > [
|
2dup length > [
|
||||||
2dup capacity > [ over new-size over expand ] when
|
2dup capacity > [ over new-size over expand ] when
|
||||||
2dup >r >fixnum r> set-fill
|
2dup (>>length)
|
||||||
] when 2drop ;
|
] when 2drop ;
|
||||||
|
|
||||||
INSTANCE: growable sequence
|
INSTANCE: growable sequence
|
||||||
|
|
|
@ -8,7 +8,7 @@ ARTICLE: "hashtables.private" "Hashtable implementation details"
|
||||||
$nl
|
$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."
|
"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
|
$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 <hash-array> }
|
||||||
{ $subsection set-nth-pair }
|
{ $subsection set-nth-pair }
|
||||||
"If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:"
|
"If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:"
|
||||||
|
|
|
@ -1,9 +1,14 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays kernel kernel.private slots.private math assocs
|
USING: accessors arrays kernel kernel.private slots.private math
|
||||||
math.private sequences sequences.private vectors grouping ;
|
assocs math.private sequences sequences.private vectors grouping ;
|
||||||
IN: hashtables
|
IN: hashtables
|
||||||
|
|
||||||
|
TUPLE: hashtable
|
||||||
|
{ count array-capacity }
|
||||||
|
{ deleted array-capacity }
|
||||||
|
{ array array } ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: wrap ( i array -- n )
|
: wrap ( i array -- n )
|
||||||
|
@ -23,16 +28,16 @@ IN: hashtables
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: key@ ( key hash -- array n ? )
|
: key@ ( key hash -- array n ? )
|
||||||
hash-array 2dup hash@ (key@) ; inline
|
array>> 2dup hash@ (key@) ; inline
|
||||||
|
|
||||||
: <hash-array> ( n -- array )
|
: <hash-array> ( n -- array )
|
||||||
1+ next-power-of-2 4 * ((empty)) <array> ; inline
|
1+ next-power-of-2 4 * ((empty)) <array> ; inline
|
||||||
|
|
||||||
: init-hash ( hash -- )
|
: init-hash ( hash -- )
|
||||||
0 over set-hash-count 0 swap set-hash-deleted ;
|
0 >>count 0 >>deleted drop ; inline
|
||||||
|
|
||||||
: reset-hash ( n hash -- )
|
: 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? )
|
: (new-key@) ( key keys i -- keys n empty? )
|
||||||
3dup swap array-nth dup ((empty)) eq? [
|
3dup swap array-nth dup ((empty)) eq? [
|
||||||
|
@ -46,17 +51,17 @@ IN: hashtables
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: new-key@ ( key hash -- array n empty? )
|
: 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 -- )
|
: set-nth-pair ( value key seq n -- )
|
||||||
2 fixnum+fast [ set-slot ] 2keep
|
2 fixnum+fast [ set-slot ] 2keep
|
||||||
1 fixnum+fast set-slot ; inline
|
1 fixnum+fast set-slot ; inline
|
||||||
|
|
||||||
: hash-count+ ( hash -- )
|
: hash-count+ ( hash -- )
|
||||||
dup hash-count 1+ swap set-hash-count ; inline
|
[ 1+ ] change-count drop ; inline
|
||||||
|
|
||||||
: hash-deleted+ ( hash -- )
|
: hash-deleted+ ( hash -- )
|
||||||
dup hash-deleted 1+ swap set-hash-deleted ; inline
|
[ 1+ ] change-deleted drop ; inline
|
||||||
|
|
||||||
: (set-hash) ( value key hash -- new? )
|
: (set-hash) ( value key hash -- new? )
|
||||||
2dup new-key@
|
2dup new-key@
|
||||||
|
@ -67,11 +72,11 @@ IN: hashtables
|
||||||
swap [ swapd (set-hash) drop ] curry assoc-each ;
|
swap [ swapd (set-hash) drop ] curry assoc-each ;
|
||||||
|
|
||||||
: hash-large? ( hash -- ? )
|
: hash-large? ( hash -- ? )
|
||||||
[ hash-count 3 fixnum*fast ]
|
[ count>> 3 fixnum*fast ]
|
||||||
[ hash-array array-capacity ] bi > ;
|
[ array>> array-capacity ] bi > ;
|
||||||
|
|
||||||
: hash-stale? ( hash -- ? )
|
: hash-stale? ( hash -- ? )
|
||||||
[ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
|
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ;
|
||||||
|
|
||||||
: grow-hash ( hash -- )
|
: grow-hash ( hash -- )
|
||||||
[ dup >alist swap assoc-size 1+ ] keep
|
[ 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 ;
|
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
|
||||||
|
|
||||||
M: hashtable clear-assoc ( hash -- )
|
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 -- )
|
M: hashtable delete-at ( key hash -- )
|
||||||
tuck key@ [
|
tuck key@ [
|
||||||
|
@ -109,14 +114,12 @@ M: hashtable delete-at ( key hash -- )
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: hashtable assoc-size ( hash -- n )
|
M: hashtable assoc-size ( hash -- n )
|
||||||
dup hash-count swap hash-deleted - ;
|
[ count>> ] [ deleted>> ] bi - ;
|
||||||
|
|
||||||
: rehash ( hash -- )
|
: rehash ( hash -- )
|
||||||
dup >alist
|
dup >alist >r
|
||||||
over hash-array length ((empty)) <array> pick set-hash-array
|
dup clear-assoc
|
||||||
0 pick set-hash-count
|
r> (rehash) ;
|
||||||
0 pick set-hash-deleted
|
|
||||||
(rehash) ;
|
|
||||||
|
|
||||||
M: hashtable set-at ( value key hash -- )
|
M: hashtable set-at ( value key hash -- )
|
||||||
dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ;
|
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 ;
|
2 <hashtable> [ set-at ] keep ;
|
||||||
|
|
||||||
M: hashtable >alist
|
M: hashtable >alist
|
||||||
hash-array 2 <groups> [ first tombstone? not ] filter ;
|
array>> 2 <groups> [ first tombstone? not ] filter ;
|
||||||
|
|
||||||
M: hashtable clone
|
M: hashtable clone
|
||||||
(clone) dup hash-array clone over set-hash-array ;
|
(clone) [ clone ] change-array ;
|
||||||
|
|
||||||
M: hashtable equal?
|
M: hashtable equal?
|
||||||
over hashtable? [
|
over hashtable? [
|
||||||
|
|
|
@ -111,7 +111,7 @@ GENERIC: apply-object ( obj -- )
|
||||||
M: object apply-object apply-literal ;
|
M: object apply-object apply-literal ;
|
||||||
|
|
||||||
M: wrapper apply-object
|
M: wrapper apply-object
|
||||||
wrapped dup +called+ depends-on apply-literal ;
|
wrapped>> dup +called+ depends-on apply-literal ;
|
||||||
|
|
||||||
: terminate ( -- )
|
: terminate ( -- )
|
||||||
terminated? on #terminate node, ;
|
terminated? on #terminate node, ;
|
||||||
|
@ -400,7 +400,7 @@ TUPLE: missing-effect word ;
|
||||||
{ [ dup inline? ] [ drop f ] }
|
{ [ dup inline? ] [ drop f ] }
|
||||||
{ [ dup deferred? ] [ drop f ] }
|
{ [ dup deferred? ] [ drop f ] }
|
||||||
{ [ dup crossref? not ] [ drop f ] }
|
{ [ dup crossref? not ] [ drop f ] }
|
||||||
[ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ]
|
[ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: ?missing-effect ( word -- )
|
: ?missing-effect ( word -- )
|
||||||
|
@ -429,7 +429,7 @@ TUPLE: missing-effect word ;
|
||||||
[
|
[
|
||||||
init-inference
|
init-inference
|
||||||
dependencies off
|
dependencies off
|
||||||
dup word-def over dup infer-quot-recursive
|
dup def>> over dup infer-quot-recursive
|
||||||
end-infer
|
end-infer
|
||||||
finish-word
|
finish-word
|
||||||
current-effect
|
current-effect
|
||||||
|
@ -492,7 +492,7 @@ M: #return collect-label-info*
|
||||||
: inline-block ( word -- #label data )
|
: inline-block ( word -- #label data )
|
||||||
[
|
[
|
||||||
copy-inference nest-node
|
copy-inference nest-node
|
||||||
[ word-def ] [ <inlined-block> ] bi
|
[ def>> ] [ <inlined-block> ] bi
|
||||||
[ infer-quot-recursive ] 2keep
|
[ infer-quot-recursive ] 2keep
|
||||||
#label unnest-node
|
#label unnest-node
|
||||||
dup collect-label-info
|
dup collect-label-info
|
||||||
|
|
|
@ -4,8 +4,9 @@ inference.dataflow optimizer tools.test kernel.private generic
|
||||||
sequences words inference.class quotations alien
|
sequences words inference.class quotations alien
|
||||||
alien.c-types strings sbufs sequences.private
|
alien.c-types strings sbufs sequences.private
|
||||||
slots.private combinators definitions compiler.units
|
slots.private combinators definitions compiler.units
|
||||||
system layouts vectors optimizer.math.partial accessors
|
system layouts vectors optimizer.math.partial
|
||||||
optimizer.inlining math.order ;
|
optimizer.inlining optimizer.backend math.order
|
||||||
|
accessors hashtables classes assocs ;
|
||||||
|
|
||||||
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
|
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
|
||||||
|
|
||||||
|
@ -159,7 +160,7 @@ DEFER: blah
|
||||||
[ dup V{ } eq? [ foo ] when ] dup second dup push define
|
[ dup V{ } eq? [ foo ] when ] dup second dup push define
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
|
|
||||||
\ blah word-def dataflow optimize drop
|
\ blah def>> dataflow optimize drop
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
GENERIC: detect-fx ( n -- n )
|
GENERIC: detect-fx ( n -- n )
|
||||||
|
@ -567,6 +568,38 @@ M: integer detect-integer ;
|
||||||
\ detect-integer inlined?
|
\ detect-integer inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ hashtable new ] \ new inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ dup hashtable eq? [ new ] when ] \ new inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ { hashtable } declare hashtable instance? ] \ instance? inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ { vector } declare hashtable instance? ] \ instance? inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
[ { assoc } declare hashtable instance? ] \ instance? inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
TUPLE: declared-fixnum { x fixnum } ;
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ { declared-fixnum } declare [ 1 + ] change-x ]
|
||||||
|
{ + fixnum+ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ { declared-fixnum } declare x>> drop ]
|
||||||
|
{ slot } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
! Later
|
! Later
|
||||||
|
|
||||||
! [ t ] [
|
! [ t ] [
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: inference.errors
|
IN: inference.errors
|
||||||
USING: inference.backend inference.dataflow kernel generic
|
USING: inference.backend inference.dataflow kernel generic
|
||||||
sequences prettyprint io words arrays inspector effects debugger
|
sequences prettyprint io words arrays summary effects debugger
|
||||||
assocs accessors ;
|
assocs accessors ;
|
||||||
|
|
||||||
M: inference-error error-help error>> error-help ;
|
M: inference-error error-help error>> error-help ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: arrays generic inference inference.backend
|
USING: accessors arrays generic inference inference.backend
|
||||||
inference.dataflow kernel classes kernel.private math
|
inference.dataflow kernel classes kernel.private math
|
||||||
math.parser math.private namespaces namespaces.private parser
|
math.parser math.private namespaces namespaces.private parser
|
||||||
sequences strings vectors words quotations effects tools.test
|
sequences strings vectors words quotations effects tools.test
|
||||||
|
@ -271,7 +271,7 @@ DEFER: #1
|
||||||
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
|
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
|
||||||
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
|
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
|
||||||
|
|
||||||
[ \ #4 word-def infer ] must-fail
|
[ \ #4 def>> infer ] must-fail
|
||||||
[ [ #1 ] infer ] must-fail
|
[ [ #1 ] infer ] must-fail
|
||||||
|
|
||||||
! Similar
|
! Similar
|
||||||
|
@ -396,6 +396,8 @@ DEFER: bar
|
||||||
\ define-tuple-class must-infer
|
\ define-tuple-class must-infer
|
||||||
\ define-union-class must-infer
|
\ define-union-class must-infer
|
||||||
\ define-predicate-class must-infer
|
\ define-predicate-class must-infer
|
||||||
|
\ instance? must-infer
|
||||||
|
\ next-method-quot must-infer
|
||||||
|
|
||||||
! Test words with continuations
|
! Test words with continuations
|
||||||
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
|
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
|
||||||
|
|
|
@ -1,16 +1,15 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.accessors arrays bit-arrays byte-arrays
|
USING: accessors alien alien.accessors arrays byte-arrays
|
||||||
classes sequences.private continuations.private effects
|
classes sequences.private continuations.private effects generic
|
||||||
float-arrays generic hashtables hashtables.private
|
hashtables hashtables.private inference.state inference.backend
|
||||||
inference.state inference.backend inference.dataflow io
|
inference.dataflow io io.backend io.files io.files.private
|
||||||
io.backend io.files io.files.private io.streams.c kernel
|
io.streams.c kernel kernel.private math math.private memory
|
||||||
kernel.private math math.private memory namespaces
|
namespaces namespaces.private parser prettyprint quotations
|
||||||
namespaces.private parser prettyprint quotations
|
|
||||||
quotations.private sbufs sbufs.private sequences
|
quotations.private sbufs sbufs.private sequences
|
||||||
sequences.private slots.private strings strings.private system
|
sequences.private slots.private strings strings.private system
|
||||||
threads.private classes.tuple classes.tuple.private vectors
|
threads.private classes.tuple classes.tuple.private vectors
|
||||||
vectors.private words words.private assocs inspector
|
vectors.private words words.private assocs summary
|
||||||
compiler.units system.private ;
|
compiler.units system.private ;
|
||||||
IN: inference.known-words
|
IN: inference.known-words
|
||||||
|
|
||||||
|
@ -137,7 +136,7 @@ M: object infer-call
|
||||||
! Variadic tuple constructor
|
! Variadic tuple constructor
|
||||||
\ <tuple-boa> [
|
\ <tuple-boa> [
|
||||||
\ <tuple-boa>
|
\ <tuple-boa>
|
||||||
peek-d value-literal layout-size { tuple } <effect>
|
peek-d value-literal size>> { tuple } <effect>
|
||||||
make-call-node
|
make-call-node
|
||||||
] "infer" set-word-prop
|
] "infer" set-word-prop
|
||||||
|
|
||||||
|
@ -399,12 +398,6 @@ set-primitive-effect
|
||||||
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
|
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
|
||||||
\ <byte-array> make-flushable
|
\ <byte-array> make-flushable
|
||||||
|
|
||||||
\ <bit-array> { integer } { bit-array } <effect> set-primitive-effect
|
|
||||||
\ <bit-array> make-flushable
|
|
||||||
|
|
||||||
\ <float-array> { integer float } { float-array } <effect> set-primitive-effect
|
|
||||||
\ <float-array> make-flushable
|
|
||||||
|
|
||||||
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
|
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
|
||||||
\ <displaced-alien> make-flushable
|
\ <displaced-alien> make-flushable
|
||||||
|
|
||||||
|
@ -492,12 +485,6 @@ set-primitive-effect
|
||||||
\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
|
\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
|
||||||
\ resize-byte-array make-flushable
|
\ resize-byte-array make-flushable
|
||||||
|
|
||||||
\ resize-bit-array { integer bit-array } { bit-array } <effect> set-primitive-effect
|
|
||||||
\ resize-bit-array make-flushable
|
|
||||||
|
|
||||||
\ resize-float-array { integer float-array } { float-array } <effect> set-primitive-effect
|
|
||||||
\ resize-float-array make-flushable
|
|
||||||
|
|
||||||
\ resize-string { integer string } { string } <effect> set-primitive-effect
|
\ resize-string { integer string } { string } <effect> set-primitive-effect
|
||||||
\ resize-string make-flushable
|
\ resize-string make-flushable
|
||||||
|
|
||||||
|
@ -529,9 +516,6 @@ set-primitive-effect
|
||||||
|
|
||||||
\ fclose { alien } { } <effect> set-primitive-effect
|
\ fclose { alien } { } <effect> set-primitive-effect
|
||||||
|
|
||||||
\ expired? { object } { object } <effect> set-primitive-effect
|
|
||||||
\ expired? make-flushable
|
|
||||||
|
|
||||||
\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
|
\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
|
||||||
\ <wrapper> make-foldable
|
\ <wrapper> make-foldable
|
||||||
|
|
||||||
|
@ -550,6 +534,9 @@ set-primitive-effect
|
||||||
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
|
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
|
||||||
\ <tuple> make-flushable
|
\ <tuple> make-flushable
|
||||||
|
|
||||||
|
\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
|
||||||
|
\ (tuple) make-flushable
|
||||||
|
|
||||||
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
|
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
|
||||||
\ <tuple-layout> make-foldable
|
\ <tuple-layout> make-foldable
|
||||||
|
|
||||||
|
|
|
@ -12,8 +12,3 @@ HELP: define-transform
|
||||||
$nl
|
$nl
|
||||||
"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
|
"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
|
||||||
{ $code "\\ cond [ cond>quot ] 1 define-transform" } } ;
|
{ $code "\\ cond [ cond>quot ] 1 define-transform" } } ;
|
||||||
|
|
||||||
HELP: duplicated-slots-error
|
|
||||||
{ $values { "names" "a sequence of setter words" } }
|
|
||||||
{ $description "Throws a " { $link duplicated-slots-error } "." }
|
|
||||||
{ $error-description "Thrown by stack effect inference if a " { $link set-slots } " form is given an array of slot setters that includes duplicates. Since writing to the same slot multiple times has no useful effect, this is a programmer error, so it is caught at compile time." } ;
|
|
||||||
|
|
|
@ -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 ] 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 ;
|
: 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 ] 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 ;
|
: 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 ] 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
|
[ fixnum instance? ] must-infer
|
||||||
|
|
||||||
|
@ -51,4 +51,4 @@ C: <color> color
|
||||||
|
|
||||||
[ bad-new-test ] must-infer
|
[ bad-new-test ] must-infer
|
||||||
|
|
||||||
[ bad-new-test ] [ T{ not-a-tuple-class f V{ } } = ] must-fail-with
|
[ bad-new-test ] must-fail
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays kernel words sequences generic math namespaces
|
USING: accessors arrays kernel words sequences generic math
|
||||||
quotations assocs combinators math.bitfields inference.backend
|
namespaces quotations assocs combinators math.bitfields
|
||||||
inference.dataflow inference.state classes.tuple
|
inference.backend inference.dataflow inference.state
|
||||||
classes.tuple.private effects inspector hashtables classes
|
classes.tuple classes.tuple.private effects summary hashtables
|
||||||
generic sets definitions ;
|
classes generic sets definitions generic.standard slots.private ;
|
||||||
IN: inference.transforms
|
IN: inference.transforms
|
||||||
|
|
||||||
: pop-literals ( n -- rstate seq )
|
: pop-literals ( n -- rstate seq )
|
||||||
|
@ -86,31 +86,14 @@ M: duplicated-slots-error summary
|
||||||
\ boa [
|
\ boa [
|
||||||
dup tuple-class? [
|
dup tuple-class? [
|
||||||
dup +inlined+ depends-on
|
dup +inlined+ depends-on
|
||||||
tuple-layout [ <tuple-boa> ] curry
|
[ "boa-check" word-prop ]
|
||||||
|
[ tuple-layout [ <tuple-boa> ] curry ]
|
||||||
|
bi append
|
||||||
] [
|
] [
|
||||||
[ not-a-tuple-class ] curry time-bomb
|
\ boa \ no-method boa time-bomb
|
||||||
] if
|
] if
|
||||||
] 1 define-transform
|
] 1 define-transform
|
||||||
|
|
||||||
\ new [
|
|
||||||
1 ensure-values
|
|
||||||
peek-d value? [
|
|
||||||
pop-literal dup tuple-class? [
|
|
||||||
dup +inlined+ depends-on
|
|
||||||
tuple-layout [ <tuple> ] curry
|
|
||||||
swap infer-quot
|
|
||||||
] [
|
|
||||||
\ not-a-tuple-class boa time-bomb drop
|
|
||||||
] if
|
|
||||||
] [
|
|
||||||
\ new (( class -- tuple )) make-call-node
|
|
||||||
] if
|
|
||||||
] "infer" set-word-prop
|
|
||||||
|
|
||||||
\ instance? [
|
|
||||||
[ +inlined+ depends-on ] [ "predicate" word-prop ] bi
|
|
||||||
] 1 define-transform
|
|
||||||
|
|
||||||
\ (call-next-method) [
|
\ (call-next-method) [
|
||||||
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
|
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
|
||||||
] 2 define-transform
|
] 2 define-transform
|
||||||
|
|
|
@ -22,9 +22,7 @@ $nl
|
||||||
{ $subsection inspector-hook }
|
{ $subsection inspector-hook }
|
||||||
"A description of an object can be printed without starting the inspector:"
|
"A description of an object can be printed without starting the inspector:"
|
||||||
{ $subsection describe }
|
{ $subsection describe }
|
||||||
{ $subsection describe* }
|
{ $subsection describe* } ;
|
||||||
"A word for getting very brief descriptions of words and general objects:"
|
|
||||||
{ $subsection summary } ;
|
|
||||||
|
|
||||||
ABOUT: "inspector"
|
ABOUT: "inspector"
|
||||||
|
|
||||||
|
@ -54,10 +52,6 @@ $nl
|
||||||
} }
|
} }
|
||||||
{ $notes "This word is a factor of " { $link describe } " and " { $link inspect } "." } ;
|
{ $notes "This word is a factor of " { $link describe } " and " { $link inspect } "." } ;
|
||||||
|
|
||||||
HELP: summary
|
|
||||||
{ $values { "object" object } { "string" "a string" } }
|
|
||||||
{ $contract "Outputs a brief description of the object." } ;
|
|
||||||
|
|
||||||
HELP: inspector-stack
|
HELP: inspector-stack
|
||||||
{ $var-description "If the inspector is running, this variable holds previously-inspected objects." } ;
|
{ $var-description "If the inspector is running, this variable holds previously-inspected objects." } ;
|
||||||
|
|
||||||
|
|
|
@ -1,48 +1,11 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
namespaces prettyprint sequences strings io.styles vectors words
|
||||||
quotations mirrors splitting math.parser classes vocabs refs
|
quotations mirrors splitting math.parser classes vocabs refs
|
||||||
sets sorting ;
|
sets sorting summary debugger continuations ;
|
||||||
IN: inspector
|
IN: inspector
|
||||||
|
|
||||||
GENERIC: summary ( object -- string )
|
|
||||||
|
|
||||||
: object-summary ( object -- string )
|
|
||||||
class word-name " instance" append ;
|
|
||||||
|
|
||||||
M: object summary object-summary ;
|
|
||||||
|
|
||||||
M: input summary
|
|
||||||
[
|
|
||||||
"Input: " %
|
|
||||||
input-string "\n" split1 swap %
|
|
||||||
"..." "" ? %
|
|
||||||
] "" make ;
|
|
||||||
|
|
||||||
M: word summary synopsis ;
|
|
||||||
|
|
||||||
M: sequence summary
|
|
||||||
[
|
|
||||||
dup class word-name %
|
|
||||||
" with " %
|
|
||||||
length #
|
|
||||||
" elements" %
|
|
||||||
] "" make ;
|
|
||||||
|
|
||||||
M: assoc summary
|
|
||||||
[
|
|
||||||
dup class word-name %
|
|
||||||
" with " %
|
|
||||||
assoc-size #
|
|
||||||
" entries" %
|
|
||||||
] "" make ;
|
|
||||||
|
|
||||||
! Override sequence => integer instance
|
|
||||||
M: f summary object-summary ;
|
|
||||||
|
|
||||||
M: integer summary object-summary ;
|
|
||||||
|
|
||||||
: value-editor ( path -- )
|
: value-editor ( path -- )
|
||||||
[
|
[
|
||||||
[ pprint-short ] presented-printer set
|
[ pprint-short ] presented-printer set
|
||||||
|
@ -79,11 +42,11 @@ SYMBOL: +editable+
|
||||||
: summary. ( obj -- ) [ summary ] keep write-object nl ;
|
: summary. ( obj -- ) [ summary ] keep write-object nl ;
|
||||||
|
|
||||||
: sorted-keys ( assoc -- alist )
|
: sorted-keys ( assoc -- alist )
|
||||||
dup mirror? [ keys ] [
|
dup hashtable? [
|
||||||
keys
|
keys
|
||||||
[ [ unparse-short ] keep ] { } map>assoc
|
[ [ unparse-short ] keep ] { } map>assoc
|
||||||
sort-keys values
|
sort-keys values
|
||||||
] if ;
|
] [ keys ] if ;
|
||||||
|
|
||||||
: describe* ( obj flags -- )
|
: describe* ( obj flags -- )
|
||||||
clone [
|
clone [
|
||||||
|
@ -101,6 +64,8 @@ SYMBOL: +editable+
|
||||||
|
|
||||||
: describe ( obj -- ) H{ } describe* ;
|
: describe ( obj -- ) H{ } describe* ;
|
||||||
|
|
||||||
|
M: tuple error. describe ;
|
||||||
|
|
||||||
: namestack. ( seq -- )
|
: namestack. ( seq -- )
|
||||||
[ [ global eq? not ] filter [ keys ] gather ] keep
|
[ [ global eq? not ] filter [ keys ] gather ] keep
|
||||||
[ dupd assoc-stack ] curry H{ } map>assoc describe ;
|
[ dupd assoc-stack ] curry H{ } map>assoc describe ;
|
||||||
|
@ -108,6 +73,9 @@ SYMBOL: +editable+
|
||||||
: .vars ( -- )
|
: .vars ( -- )
|
||||||
namestack namestack. ;
|
namestack namestack. ;
|
||||||
|
|
||||||
|
: :vars ( -- )
|
||||||
|
error-continuation get continuation-name namestack. ;
|
||||||
|
|
||||||
SYMBOL: inspector-hook
|
SYMBOL: inspector-hook
|
||||||
|
|
||||||
[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
|
[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
|
||||||
|
|
|
@ -4,5 +4,3 @@ IN: io.encodings.binary
|
||||||
HELP: binary
|
HELP: binary
|
||||||
{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." }
|
{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." }
|
||||||
{ $see-also "encodings-introduction" } ;
|
{ $see-also "encodings-introduction" } ;
|
||||||
|
|
||||||
ABOUT: binary
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2006, 2008 Daniel Ehrenberg.
|
! Copyright (C) 2006, 2008 Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: math kernel sequences sbufs vectors namespaces io.binary
|
USING: math kernel sequences sbufs vectors namespaces io.binary
|
||||||
io.encodings combinators splitting io byte-arrays inspector ;
|
io.encodings combinators splitting io byte-arrays summary ;
|
||||||
IN: io.encodings.utf16
|
IN: io.encodings.utf16
|
||||||
|
|
||||||
SINGLETON: utf16be
|
SINGLETON: utf16be
|
||||||
|
|
|
@ -4,5 +4,3 @@ IN: io.encodings.utf8
|
||||||
HELP: utf8
|
HELP: utf8
|
||||||
{ $class-description "This is the encoding descriptor for a UTF-8 encoding. UTF-8 is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." }
|
{ $class-description "This is the encoding descriptor for a UTF-8 encoding. UTF-8 is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." }
|
||||||
{ $see-also "encodings-introduction" } ;
|
{ $see-also "encodings-introduction" } ;
|
||||||
|
|
||||||
ABOUT: utf8
|
|
||||||
|
|
|
@ -121,7 +121,8 @@ ARTICLE: "io.files" "Basic file operations"
|
||||||
{ $subsection "file-streams" }
|
{ $subsection "file-streams" }
|
||||||
{ $subsection "fs-meta" }
|
{ $subsection "fs-meta" }
|
||||||
{ $subsection "directories" }
|
{ $subsection "directories" }
|
||||||
{ $subsection "delete-move-copy" } ;
|
{ $subsection "delete-move-copy" }
|
||||||
|
{ $subsection "symbolic-links" } ;
|
||||||
|
|
||||||
ABOUT: "io.files"
|
ABOUT: "io.files"
|
||||||
|
|
||||||
|
|
|
@ -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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io kernel math namespaces sequences sbufs strings
|
USING: accessors io kernel math namespaces sequences sbufs
|
||||||
generic splitting growable continuations destructors
|
strings generic splitting continuations destructors
|
||||||
io.streams.plain io.encodings math.order ;
|
io.streams.plain io.encodings math.order growable ;
|
||||||
IN: io.streams.string
|
IN: io.streams.string
|
||||||
|
|
||||||
M: growable dispose drop ;
|
M: growable dispose drop ;
|
||||||
|
@ -21,7 +21,7 @@ M: growable stream-flush drop ;
|
||||||
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
|
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
|
||||||
|
|
||||||
: harden-as ( seq growble-exemplar -- newseq )
|
: harden-as ( seq growble-exemplar -- newseq )
|
||||||
underlying like ;
|
underlying>> like ;
|
||||||
|
|
||||||
: growable-read-until ( growable n -- str )
|
: growable-read-until ( growable n -- str )
|
||||||
>fixnum dupd tail-slice swap harden-as dup reverse-here ;
|
>fixnum dupd tail-slice swap harden-as dup reverse-here ;
|
||||||
|
|
|
@ -94,7 +94,7 @@ HELP: font-style
|
||||||
{ $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." }
|
{ $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." }
|
||||||
{ $examples
|
{ $examples
|
||||||
"This example outputs text in all three styles:"
|
"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
|
HELP: presented
|
||||||
|
|
|
@ -142,11 +142,9 @@ M: object clone ;
|
||||||
M: callstack clone (clone) ;
|
M: callstack clone (clone) ;
|
||||||
|
|
||||||
! Tuple construction
|
! Tuple construction
|
||||||
: new ( class -- tuple )
|
GENERIC: new ( class -- tuple )
|
||||||
tuple-layout <tuple> ;
|
|
||||||
|
|
||||||
: boa ( ... class -- tuple )
|
GENERIC: boa ( ... class -- tuple )
|
||||||
tuple-layout <tuple-boa> ;
|
|
||||||
|
|
||||||
! Quotation building
|
! Quotation building
|
||||||
: 2curry ( obj1 obj2 quot -- curry )
|
: 2curry ( obj1 obj2 quot -- curry )
|
||||||
|
@ -197,8 +195,16 @@ M: callstack clone (clone) ;
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
! Deprecated
|
! Deprecated
|
||||||
|
GENERIC: delegate ( obj -- delegate )
|
||||||
|
|
||||||
|
M: tuple delegate 2 slot ;
|
||||||
|
|
||||||
M: object delegate drop f ;
|
M: object delegate drop f ;
|
||||||
|
|
||||||
|
GENERIC: set-delegate ( delegate tuple -- )
|
||||||
|
|
||||||
|
M: tuple set-delegate 2 set-slot ;
|
||||||
|
|
||||||
GENERIC# get-slots 1 ( tuple slots -- ... )
|
GENERIC# get-slots 1 ( tuple slots -- ... )
|
||||||
|
|
||||||
GENERIC# set-slots 1 ( ... tuple slots -- )
|
GENERIC# set-slots 1 ( ... tuple slots -- )
|
||||||
|
|
|
@ -107,12 +107,15 @@ ARTICLE: "layouts-limits" "Sizes and limits"
|
||||||
{ $subsection max-array-capacity } ;
|
{ $subsection max-array-capacity } ;
|
||||||
|
|
||||||
ARTICLE: "layouts-bootstrap" "Bootstrap support"
|
ARTICLE: "layouts-bootstrap" "Bootstrap support"
|
||||||
"Bootstrap support:"
|
"Processor cell size for the target architecture:"
|
||||||
{ $subsection bootstrap-cell }
|
{ $subsection bootstrap-cell }
|
||||||
{ $subsection bootstrap-cells }
|
{ $subsection bootstrap-cells }
|
||||||
{ $subsection bootstrap-cell-bits }
|
{ $subsection bootstrap-cell-bits }
|
||||||
|
"Range of integers representable by " { $link fixnum } "s of the target architecture:"
|
||||||
{ $subsection bootstrap-most-negative-fixnum }
|
{ $subsection bootstrap-most-negative-fixnum }
|
||||||
{ $subsection bootstrap-most-positive-fixnum } ;
|
{ $subsection bootstrap-most-positive-fixnum }
|
||||||
|
"Maximum array size for the target architecture:"
|
||||||
|
{ $subsection bootstrap-max-array-capacity } ;
|
||||||
|
|
||||||
ARTICLE: "layouts" "VM memory layouts"
|
ARTICLE: "layouts" "VM memory layouts"
|
||||||
"The words documented in this section do not ever need to be called by user code. They are documented for the benefit of those wishing to explore the internals of Factor's implementation."
|
"The words documented in this section do not ever need to be called by user code. They are documented for the benefit of those wishing to explore the internals of Factor's implementation."
|
||||||
|
|
|
@ -3,3 +3,6 @@ USING: layouts math tools.test ;
|
||||||
|
|
||||||
[ t ] [ cell integer? ] unit-test
|
[ t ] [ cell integer? ] unit-test
|
||||||
[ t ] [ bootstrap-cell integer? ] unit-test
|
[ t ] [ bootstrap-cell integer? ] unit-test
|
||||||
|
|
||||||
|
! Smoke test
|
||||||
|
[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test
|
||||||
|
|
|
@ -49,6 +49,12 @@ SYMBOL: type-numbers
|
||||||
: most-negative-fixnum ( -- n )
|
: most-negative-fixnum ( -- n )
|
||||||
first-bignum neg ;
|
first-bignum neg ;
|
||||||
|
|
||||||
|
: (max-array-capacity) ( b -- n )
|
||||||
|
5 - 2^ 1- ;
|
||||||
|
|
||||||
|
: max-array-capacity ( -- n )
|
||||||
|
cell-bits (max-array-capacity) ;
|
||||||
|
|
||||||
: bootstrap-first-bignum ( -- n )
|
: bootstrap-first-bignum ( -- n )
|
||||||
bootstrap-cell-bits (first-bignum) ;
|
bootstrap-cell-bits (first-bignum) ;
|
||||||
|
|
||||||
|
@ -58,6 +64,9 @@ SYMBOL: type-numbers
|
||||||
: bootstrap-most-negative-fixnum ( -- n )
|
: bootstrap-most-negative-fixnum ( -- n )
|
||||||
bootstrap-first-bignum neg ;
|
bootstrap-first-bignum neg ;
|
||||||
|
|
||||||
|
: bootstrap-max-array-capacity ( -- n )
|
||||||
|
bootstrap-cell-bits (max-array-capacity) ;
|
||||||
|
|
||||||
M: bignum >integer
|
M: bignum >integer
|
||||||
dup most-negative-fixnum most-positive-fixnum between?
|
dup most-negative-fixnum most-positive-fixnum between?
|
||||||
[ >fixnum ] when ;
|
[ >fixnum ] when ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sequences accessors namespaces math words strings
|
USING: kernel sequences accessors namespaces math words strings
|
||||||
debugger io vectors arrays math.parser combinators inspector
|
debugger io vectors arrays math.parser combinators summary
|
||||||
continuations ;
|
continuations ;
|
||||||
IN: lexer
|
IN: lexer
|
||||||
|
|
||||||
|
@ -71,7 +71,7 @@ ERROR: unexpected want got ;
|
||||||
GENERIC: expected>string ( obj -- str )
|
GENERIC: expected>string ( obj -- str )
|
||||||
|
|
||||||
M: f expected>string drop "end of input" ;
|
M: f expected>string drop "end of input" ;
|
||||||
M: word expected>string word-name ;
|
M: word expected>string name>> ;
|
||||||
M: string expected>string ;
|
M: string expected>string ;
|
||||||
|
|
||||||
M: unexpected error.
|
M: unexpected error.
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: math math.bitfields tools.test kernel words ;
|
USING: accessors math math.bitfields tools.test kernel words ;
|
||||||
IN: math.bitfields.tests
|
IN: math.bitfields.tests
|
||||||
|
|
||||||
[ 0 ] [ { } bitfield ] unit-test
|
[ 0 ] [ { } bitfield ] unit-test
|
||||||
|
@ -14,4 +14,4 @@ IN: math.bitfields.tests
|
||||||
|
|
||||||
[ 3 ] [ foo ] unit-test
|
[ 3 ] [ foo ] unit-test
|
||||||
[ 3 ] [ { a b } flags ] unit-test
|
[ 3 ] [ { a b } flags ] unit-test
|
||||||
[ t ] [ \ foo compiled? ] unit-test
|
\ foo must-infer
|
||||||
|
|
|
@ -222,3 +222,15 @@ IN: math.intervals.tests
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
|
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume>= 0 10 [a,b] = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume< -10 10 [a,b] = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ -10 10 [a,b] -100 0 [a,b] assume< -10 0 [a,b) = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ -10 10 [a,b] -100 0 [a,b] assume<= -10 0 [a,b] = ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume<= -10 10 [a,b] = ] unit-test
|
||||||
|
|
|
@ -1,10 +1,11 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
|
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
|
||||||
USING: kernel sequences arrays math combinators math.order ;
|
USING: accessors kernel sequences arrays math math.order
|
||||||
|
combinators ;
|
||||||
IN: math.intervals
|
IN: math.intervals
|
||||||
|
|
||||||
TUPLE: interval from to ;
|
TUPLE: interval { from read-only } { to read-only } ;
|
||||||
|
|
||||||
C: <interval> interval
|
C: <interval> interval
|
||||||
|
|
||||||
|
@ -13,26 +14,27 @@ C: <interval> interval
|
||||||
: closed-point ( n -- endpoint ) t 2array ;
|
: closed-point ( n -- endpoint ) t 2array ;
|
||||||
|
|
||||||
: [a,b] ( a b -- interval )
|
: [a,b] ( a b -- interval )
|
||||||
>r closed-point r> closed-point <interval> ;
|
>r closed-point r> closed-point <interval> ; foldable
|
||||||
|
|
||||||
: (a,b) ( a b -- interval )
|
: (a,b) ( a b -- interval )
|
||||||
>r open-point r> open-point <interval> ;
|
>r open-point r> open-point <interval> ; foldable
|
||||||
|
|
||||||
: [a,b) ( a b -- interval )
|
: [a,b) ( a b -- interval )
|
||||||
>r closed-point r> open-point <interval> ;
|
>r closed-point r> open-point <interval> ; foldable
|
||||||
|
|
||||||
: (a,b] ( a b -- interval )
|
: (a,b] ( a b -- interval )
|
||||||
>r open-point r> closed-point <interval> ;
|
>r open-point r> closed-point <interval> ; foldable
|
||||||
|
|
||||||
: [a,a] ( a -- interval ) closed-point dup <interval> ;
|
: [a,a] ( a -- interval )
|
||||||
|
closed-point dup <interval> ; foldable
|
||||||
|
|
||||||
: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ;
|
: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline
|
||||||
|
|
||||||
: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ;
|
: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline
|
||||||
|
|
||||||
: [a,inf] ( a -- interval ) 1./0. [a,b] ;
|
: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline
|
||||||
|
|
||||||
: (a,inf] ( a -- interval ) 1./0. (a,b] ;
|
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
|
||||||
|
|
||||||
: compare-endpoints ( p1 p2 quot -- ? )
|
: compare-endpoints ( p1 p2 quot -- ? )
|
||||||
>r over first over first r> call [
|
>r over first over first r> call [
|
||||||
|
@ -58,7 +60,7 @@ C: <interval> interval
|
||||||
: endpoint-max ( p1 p2 -- p3 ) [ endpoint> ] most ;
|
: endpoint-max ( p1 p2 -- p3 ) [ endpoint> ] most ;
|
||||||
|
|
||||||
: interval>points ( int -- from to )
|
: interval>points ( int -- from to )
|
||||||
dup interval-from swap interval-to ;
|
[ from>> ] [ to>> ] bi ;
|
||||||
|
|
||||||
: points>interval ( seq -- interval )
|
: points>interval ( seq -- interval )
|
||||||
dup first
|
dup first
|
||||||
|
@ -71,11 +73,12 @@ C: <interval> interval
|
||||||
r> r> [ second ] both? 2array ; inline
|
r> r> [ second ] both? 2array ; inline
|
||||||
|
|
||||||
: interval-op ( i1 i2 quot -- i3 )
|
: interval-op ( i1 i2 quot -- i3 )
|
||||||
pick interval-from pick interval-from pick (interval-op) >r
|
{
|
||||||
pick interval-to pick interval-from pick (interval-op) >r
|
[ [ from>> ] [ from>> ] [ ] tri* (interval-op) ]
|
||||||
pick interval-to pick interval-to pick (interval-op) >r
|
[ [ to>> ] [ from>> ] [ ] tri* (interval-op) ]
|
||||||
pick interval-from pick interval-to pick (interval-op) >r
|
[ [ to>> ] [ to>> ] [ ] tri* (interval-op) ]
|
||||||
3drop r> r> r> r> 4array points>interval ; inline
|
[ [ from>> ] [ to>> ] [ ] tri* (interval-op) ]
|
||||||
|
} 3cleave 4array points>interval ; inline
|
||||||
|
|
||||||
: interval+ ( i1 i2 -- i3 ) [ + ] interval-op ;
|
: interval+ ( i1 i2 -- i3 ) [ + ] interval-op ;
|
||||||
|
|
||||||
|
@ -150,7 +153,7 @@ C: <interval> interval
|
||||||
[ [ shift ] interval-op ] interval-integer-op interval-closure ;
|
[ [ shift ] interval-op ] interval-integer-op interval-closure ;
|
||||||
|
|
||||||
: interval-shift-safe ( i1 i2 -- i3 )
|
: interval-shift-safe ( i1 i2 -- i3 )
|
||||||
dup interval-to first 100 > [
|
dup to>> first 100 > [
|
||||||
2drop f
|
2drop f
|
||||||
] [
|
] [
|
||||||
interval-shift
|
interval-shift
|
||||||
|
@ -188,17 +191,17 @@ SYMBOL: incomparable
|
||||||
: left-endpoint-< ( i1 i2 -- ? )
|
: left-endpoint-< ( i1 i2 -- ? )
|
||||||
[ swap interval-subset? ] 2keep
|
[ swap interval-subset? ] 2keep
|
||||||
[ nip interval-singleton? ] 2keep
|
[ nip interval-singleton? ] 2keep
|
||||||
[ interval-from ] bi@ =
|
[ from>> ] bi@ =
|
||||||
and and ;
|
and and ;
|
||||||
|
|
||||||
: right-endpoint-< ( i1 i2 -- ? )
|
: right-endpoint-< ( i1 i2 -- ? )
|
||||||
[ interval-subset? ] 2keep
|
[ interval-subset? ] 2keep
|
||||||
[ drop interval-singleton? ] 2keep
|
[ drop interval-singleton? ] 2keep
|
||||||
[ interval-to ] bi@ =
|
[ to>> ] bi@ =
|
||||||
and and ;
|
and and ;
|
||||||
|
|
||||||
: (interval<) ( i1 i2 -- i1 i2 ? )
|
: (interval<) ( i1 i2 -- i1 i2 ? )
|
||||||
over interval-from over interval-from endpoint< ;
|
over from>> over from>> endpoint< ;
|
||||||
|
|
||||||
: interval< ( i1 i2 -- ? )
|
: interval< ( i1 i2 -- ? )
|
||||||
{
|
{
|
||||||
|
@ -209,10 +212,10 @@ SYMBOL: incomparable
|
||||||
} cond 2nip ;
|
} cond 2nip ;
|
||||||
|
|
||||||
: left-endpoint-<= ( i1 i2 -- ? )
|
: left-endpoint-<= ( i1 i2 -- ? )
|
||||||
>r interval-from r> interval-to = ;
|
>r from>> r> to>> = ;
|
||||||
|
|
||||||
: right-endpoint-<= ( i1 i2 -- ? )
|
: right-endpoint-<= ( i1 i2 -- ? )
|
||||||
>r interval-to r> interval-from = ;
|
>r to>> r> from>> = ;
|
||||||
|
|
||||||
: interval<= ( i1 i2 -- ? )
|
: interval<= ( i1 i2 -- ? )
|
||||||
{
|
{
|
||||||
|
@ -228,18 +231,18 @@ SYMBOL: incomparable
|
||||||
swap interval<= ;
|
swap interval<= ;
|
||||||
|
|
||||||
: assume< ( i1 i2 -- i3 )
|
: assume< ( i1 i2 -- i3 )
|
||||||
interval-to first [-inf,a) interval-intersect ;
|
to>> first [-inf,a) interval-intersect ;
|
||||||
|
|
||||||
: assume<= ( i1 i2 -- i3 )
|
: assume<= ( i1 i2 -- i3 )
|
||||||
interval-to first [-inf,a] interval-intersect ;
|
to>> first [-inf,a] interval-intersect ;
|
||||||
|
|
||||||
: assume> ( i1 i2 -- i3 )
|
: assume> ( i1 i2 -- i3 )
|
||||||
interval-from first (a,inf] interval-intersect ;
|
from>> first (a,inf] interval-intersect ;
|
||||||
|
|
||||||
: assume>= ( i1 i2 -- i3 )
|
: assume>= ( i1 i2 -- i3 )
|
||||||
interval-to first [a,inf] interval-intersect ;
|
from>> first [a,inf] interval-intersect ;
|
||||||
|
|
||||||
: integral-closure ( i1 -- i2 )
|
: integral-closure ( i1 -- i2 )
|
||||||
dup interval-from first2 [ 1+ ] unless
|
[ from>> first2 [ 1+ ] unless ]
|
||||||
swap interval-to first2 [ 1- ] unless
|
[ to>> first2 [ 1- ] unless ]
|
||||||
[a,b] ;
|
bi [a,b] ;
|
||||||
|
|
|
@ -302,11 +302,11 @@ HELP: fp-nan?
|
||||||
{ $values { "x" real } { "?" "a boolean" } }
|
{ $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 } "." } ;
|
{ $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 } }
|
{ $values { "z" number } { "x" real } }
|
||||||
{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } ;
|
{ $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 } }
|
{ $values { "z" number } { "y" real } }
|
||||||
{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ;
|
{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ;
|
||||||
|
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue