Working on shapes
Slava Pestov
parent
a0e1659a3e
commit
e1ad21a439
|
|
@ -93,3 +93,14 @@ unit-test
|
|||
] [
|
||||
F{ 1.0 2.0 } [ dup ] H{ } map>assoc
|
||||
] unit-test
|
||||
|
||||
[ { 3 } ] [
|
||||
[
|
||||
3
|
||||
H{ } clone
|
||||
2 [
|
||||
2dup [ , f ] cache
|
||||
] times
|
||||
2drop
|
||||
] make
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -134,11 +134,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
(substitute) map ;
|
||||
|
||||
: cache ( key assoc quot -- value )
|
||||
2over at [
|
||||
2over at* [
|
||||
>r 3drop r>
|
||||
] [
|
||||
pick rot >r >r call dup r> r> set-at
|
||||
] if* ; inline
|
||||
drop pick rot >r >r call dup r> r> set-at
|
||||
] if ; inline
|
||||
|
||||
: change-at ( key assoc quot -- )
|
||||
[ >r at r> call ] 3keep drop set-at ; inline
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ nl
|
|||
{
|
||||
roll -roll declare not
|
||||
|
||||
tuple-class-eq? array? hashtable? vector?
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? node? tombstone?
|
||||
|
||||
array-capacity array-nth set-array-nth
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
|
|||
hashtables assocs hashtables.private io kernel kernel.private
|
||||
math namespaces parser prettyprint sequences sequences.private
|
||||
strings sbufs vectors words quotations assocs system layouts
|
||||
splitting growable classes tuples words.private
|
||||
splitting growable classes tuples tuples.private words.private
|
||||
io.binary io.files vocabs vocabs.loader source-files
|
||||
definitions debugger float-arrays quotations.private
|
||||
sequences.private combinators io.encodings.binary ;
|
||||
|
|
@ -294,17 +294,14 @@ M: bit-array ' bit-array emit-dummy-array ;
|
|||
|
||||
M: float-array ' float-array emit-dummy-array ;
|
||||
|
||||
! Arrays
|
||||
: emit-array ( list type tag -- pointer )
|
||||
>r >r [ ' ] map r> r> [
|
||||
dup length emit-fixnum
|
||||
emit-seq
|
||||
] emit-object ;
|
||||
|
||||
: emit-tuple ( obj -- pointer )
|
||||
! Tuples
|
||||
: emit-tuple ( tuple -- pointer )
|
||||
[
|
||||
[ tuple>array unclip transfer-word , % ] { } make
|
||||
tuple type-number dup emit-array
|
||||
[
|
||||
dup class transfer-word tuple-layout ' ,
|
||||
tuple>array 1 tail-slice [ ' ] map %
|
||||
] { } make
|
||||
tuple type-number dup [ emit-seq ] emit-object
|
||||
]
|
||||
! Hack
|
||||
over class word-name "tombstone" =
|
||||
|
|
@ -312,11 +309,31 @@ M: float-array ' float-array emit-dummy-array ;
|
|||
|
||||
M: tuple ' emit-tuple ;
|
||||
|
||||
M: tuple-layout '
|
||||
objects get [
|
||||
[
|
||||
dup layout-hashcode ' ,
|
||||
dup layout-class ' ,
|
||||
dup layout-size ' ,
|
||||
dup layout-superclasses ' ,
|
||||
layout-echelon ' ,
|
||||
] { } make
|
||||
\ tuple-layout type-number
|
||||
object tag-number [ emit-seq ] emit-object
|
||||
] cache ;
|
||||
|
||||
M: tombstone '
|
||||
delegate
|
||||
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
||||
word-def first objects get [ emit-tuple ] cache ;
|
||||
|
||||
! Arrays
|
||||
: emit-array ( list type tag -- pointer )
|
||||
>r >r [ ' ] map r> r> [
|
||||
dup length emit-fixnum
|
||||
emit-seq
|
||||
] emit-object ;
|
||||
|
||||
M: array '
|
||||
array type-number object tag-number emit-array ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,13 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces math words kernel alien byte-arrays
|
||||
hashtables vectors strings sbufs arrays bit-arrays
|
||||
float-arrays quotations assocs layouts tuples ;
|
||||
float-arrays quotations assocs layouts tuples tuples.private ;
|
||||
|
||||
BIN: 111 tag-mask set
|
||||
8 num-tags set
|
||||
3 tag-bits set
|
||||
|
||||
19 num-types set
|
||||
20 num-types set
|
||||
|
||||
H{
|
||||
{ fixnum BIN: 000 }
|
||||
|
|
@ -33,4 +33,5 @@ tag-numbers get H{
|
|||
{ alien 16 }
|
||||
{ word 17 }
|
||||
{ byte-array 18 }
|
||||
{ tuple-layout 19 }
|
||||
} union type-numbers set
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: alien arrays byte-arrays generic hashtables
|
||||
hashtables.private io kernel math namespaces parser sequences
|
||||
strings vectors words quotations assocs layouts classes tuples
|
||||
kernel.private vocabs vocabs.loader source-files definitions
|
||||
slots.deprecated classes.union compiler.units
|
||||
tuples.private kernel.private vocabs vocabs.loader source-files
|
||||
definitions slots.deprecated classes.union compiler.units
|
||||
bootstrap.image.private io.files ;
|
||||
IN: bootstrap.primitives
|
||||
|
||||
|
|
@ -33,7 +33,6 @@ H{ } clone changed-words set
|
|||
H{ } clone root-cache set
|
||||
H{ } clone source-files set
|
||||
H{ } clone update-map set
|
||||
num-types get f <array> builtins set
|
||||
init-caches
|
||||
|
||||
! Vocabulary for slot accessors
|
||||
|
|
@ -47,6 +46,9 @@ call
|
|||
call
|
||||
call
|
||||
|
||||
! After we execute bootstrap/layouts
|
||||
num-types get f <array> builtins set
|
||||
|
||||
! Create some empty vocabs where the below primitives and
|
||||
! classes will go
|
||||
{
|
||||
|
|
@ -141,8 +143,6 @@ call
|
|||
"bignum" "math" create { } define-builtin
|
||||
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"tuple" "kernel" create { } define-builtin
|
||||
|
||||
"ratio" "math" create {
|
||||
{
|
||||
{ "integer" "math" }
|
||||
|
|
@ -178,8 +178,6 @@ call
|
|||
|
||||
"f" "syntax" lookup { } define-builtin
|
||||
|
||||
! do not word...
|
||||
|
||||
"array" "arrays" create { } define-builtin
|
||||
|
||||
"wrapper" "kernel" create {
|
||||
|
|
@ -293,6 +291,48 @@ define-builtin
|
|||
|
||||
"callstack" "kernel" create { } define-builtin
|
||||
|
||||
"tuple-layout" "tuples.private" create {
|
||||
{
|
||||
{ "fixnum" "math" }
|
||||
"hashcode"
|
||||
{ "layout-hashcode" "tuples.private" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "word" "words" }
|
||||
"class"
|
||||
{ "layout-class" "tuples.private" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "fixnum" "math" }
|
||||
"size"
|
||||
{ "layout-size" "tuples.private" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "array" "arrays" }
|
||||
"superclasses"
|
||||
{ "layout-superclasses" "tuples.private" }
|
||||
f
|
||||
}
|
||||
{
|
||||
{ "fixnum" "math" }
|
||||
"echelon"
|
||||
{ "layout-echelon" "tuples.private" }
|
||||
f
|
||||
}
|
||||
} define-builtin
|
||||
|
||||
"tuple" "kernel" create {
|
||||
{
|
||||
{ "tuple-layout" "tuples.private" }
|
||||
"layout"
|
||||
{ "tuple-layout" "tuples.private" }
|
||||
f
|
||||
}
|
||||
} define-builtin
|
||||
|
||||
! Define general-t type, which is any object that is not f.
|
||||
"general-t" "kernel" create
|
||||
"f" "syntax" lookup builtins get remove [ ] subset f union-class
|
||||
|
|
@ -439,6 +479,10 @@ builtins get num-tags get tail f union-class define-class
|
|||
}
|
||||
} define-tuple-class
|
||||
|
||||
"curry" "kernel" lookup
|
||||
dup f "inline" set-word-prop
|
||||
dup tuple-layout [ <tuple-boa> ] curry define
|
||||
|
||||
"compose" "kernel" create
|
||||
{
|
||||
{
|
||||
|
|
@ -454,6 +498,10 @@ builtins get num-tags get tail f union-class define-class
|
|||
}
|
||||
} define-tuple-class
|
||||
|
||||
"compose" "kernel" lookup
|
||||
dup f "inline" set-word-prop
|
||||
dup tuple-layout [ <tuple-boa> ] curry define
|
||||
|
||||
! Primitive words
|
||||
: make-primitive ( word vocab n -- )
|
||||
>r create dup reset-word r>
|
||||
|
|
@ -628,11 +676,10 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "<wrapper>" "kernel" }
|
||||
{ "(clone)" "kernel" }
|
||||
{ "<string>" "strings" }
|
||||
{ "(>tuple)" "tuples.private" }
|
||||
{ "array>quotation" "quotations.private" }
|
||||
{ "quotation-xt" "quotations" }
|
||||
{ "<tuple>" "tuples.private" }
|
||||
{ "tuple>array" "tuples" }
|
||||
{ "<tuple-layout>" "tuples.private" }
|
||||
{ "profiling" "tools.profiler.private" }
|
||||
{ "become" "kernel.private" }
|
||||
{ "(sleep)" "threads.private" }
|
||||
|
|
|
|||
|
|
@ -118,10 +118,3 @@ GENERIC: update-methods ( assoc -- )
|
|||
GENERIC: class ( object -- class ) inline
|
||||
|
||||
M: object class type type>class ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: class-of-tuple ( obj -- class )
|
||||
2 slot { word } declare ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ IN: compiler.constants
|
|||
: byte-array-offset 2 bootstrap-cells object tag-number - ;
|
||||
: alien-offset 3 bootstrap-cells object tag-number - ;
|
||||
: underlying-alien-offset bootstrap-cell object tag-number - ;
|
||||
: tuple-class-offset 2 bootstrap-cells tuple tag-number - ;
|
||||
: tuple-class-offset bootstrap-cell tuple tag-number - ;
|
||||
: class-hash-offset bootstrap-cell object tag-number - ;
|
||||
: word-xt-offset 8 bootstrap-cells object tag-number - ;
|
||||
: word-code-offset 9 bootstrap-cells object tag-number - ;
|
||||
|
|
|
|||
|
|
@ -479,19 +479,17 @@ IN: cpu.ppc.intrinsics
|
|||
} define-intrinsic
|
||||
|
||||
\ <tuple> [
|
||||
tuple "n" get 2 + cells %allot
|
||||
! Store length
|
||||
"n" operand 12 LI
|
||||
tuple "layout" get layout-size 2 + cells %allot
|
||||
! Store layout
|
||||
"layout" operand 12 LOAD32
|
||||
12 11 cell STW
|
||||
! Store class
|
||||
"class" operand 11 2 cells STW
|
||||
! Zero out the rest of the tuple
|
||||
f v>operand 12 LI
|
||||
"n" get 1- [ 12 11 rot 3 + cells STW ] each
|
||||
"layout" get layout-size [ 12 11 rot 2 + cells STW ] each
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] H{
|
||||
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
|
||||
{ +input+ { { [ tuple-layout? ] "layout" } }
|
||||
{ +scratch+ { { f "tuple" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
|
|
|||
|
|
@ -336,19 +336,20 @@ IN: cpu.x86.intrinsics
|
|||
} define-intrinsic
|
||||
|
||||
\ <tuple> [
|
||||
tuple "n" get 2 + cells [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store class
|
||||
2 object@ "class" operand MOV
|
||||
tuple "layout" get layout-size 2 + cells [
|
||||
! Store layout
|
||||
"layout" get "scratch" get load-literal
|
||||
1 object@ "scratch" operand MOV
|
||||
! Zero out the rest of the tuple
|
||||
"n" operand 1- [ 3 + object@ f v>operand MOV ] each
|
||||
"layout" get layout-size [
|
||||
2 + object@ f v>operand MOV
|
||||
] each
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
|
||||
{ +scratch+ { { f "tuple" } } }
|
||||
{ +input+ { { [ tuple-layout? ] "layout" } } }
|
||||
{ +scratch+ { { f "tuple" } { f "scratch" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
||||
|
|
|
|||
|
|
@ -135,7 +135,7 @@ M: object infer-call
|
|||
! Variadic tuple constructor
|
||||
\ <tuple-boa> [
|
||||
\ <tuple-boa>
|
||||
peek-d value-literal { tuple } <effect>
|
||||
peek-d value-literal layout-size { tuple } <effect>
|
||||
make-call-node
|
||||
] "infer" set-word-prop
|
||||
|
||||
|
|
@ -565,14 +565,11 @@ set-primitive-effect
|
|||
\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
|
||||
\ quotation-xt make-flushable
|
||||
|
||||
\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
|
||||
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
|
||||
\ <tuple> make-flushable
|
||||
|
||||
\ (>tuple) { array } { tuple } <effect> set-primitive-effect
|
||||
\ (>tuple) make-flushable
|
||||
|
||||
\ tuple>array { tuple } { array } <effect> set-primitive-effect
|
||||
\ tuple>array make-flushable
|
||||
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
|
||||
\ <tuple-layout> make-foldable
|
||||
|
||||
\ datastack { } { array } <effect> set-primitive-effect
|
||||
\ datastack make-flushable
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ M: duplicated-slots-error summary
|
|||
|
||||
\ construct-boa [
|
||||
dup +inlined+ depends-on
|
||||
dup tuple-size [ <tuple-boa> ] 2curry
|
||||
tuple-layout [ <tuple-boa> ] curry
|
||||
] 1 define-transform
|
||||
|
||||
\ construct-empty [
|
||||
|
|
@ -84,7 +84,7 @@ M: duplicated-slots-error summary
|
|||
peek-d value? [
|
||||
pop-literal
|
||||
dup +inlined+ depends-on
|
||||
dup tuple-size [ <tuple> ] 2curry
|
||||
tuple-layout [ <tuple> ] curry
|
||||
swap infer-quot
|
||||
] [
|
||||
\ construct-empty 1 1 <effect> make-call-node
|
||||
|
|
|
|||
|
|
@ -67,29 +67,7 @@ DEFER: if
|
|||
[ >r tuck 2slip r> while ]
|
||||
[ 2nip call ] if ; inline
|
||||
|
||||
! Quotation building
|
||||
USE: tuples.private
|
||||
|
||||
: curry ( obj quot -- curry )
|
||||
\ curry 4 <tuple-boa> ;
|
||||
|
||||
: 2curry ( obj1 obj2 quot -- curry )
|
||||
curry curry ; inline
|
||||
|
||||
: 3curry ( obj1 obj2 obj3 quot -- curry )
|
||||
curry curry curry ; inline
|
||||
|
||||
: with ( param obj quot -- obj curry )
|
||||
swapd [ swapd call ] 2curry ; inline
|
||||
|
||||
: compose ( quot1 quot2 -- curry )
|
||||
\ compose 4 <tuple-boa> ;
|
||||
|
||||
: 3compose ( quot1 quot2 quot3 -- curry )
|
||||
compose compose ; inline
|
||||
|
||||
! Object protocol
|
||||
|
||||
GENERIC: delegate ( obj -- delegate )
|
||||
|
||||
M: object delegate drop f ;
|
||||
|
|
@ -118,7 +96,6 @@ M: object clone ;
|
|||
M: callstack clone (clone) ;
|
||||
|
||||
! Tuple construction
|
||||
|
||||
GENERIC# get-slots 1 ( tuple slots -- ... )
|
||||
|
||||
GENERIC# set-slots 1 ( ... tuple slots -- )
|
||||
|
|
@ -132,8 +109,22 @@ GENERIC: construct-boa ( ... class -- tuple )
|
|||
: construct-delegate ( delegate class -- tuple )
|
||||
>r { set-delegate } r> construct ; inline
|
||||
|
||||
! Booleans
|
||||
! Quotation building
|
||||
USE: tuples.private
|
||||
|
||||
: 2curry ( obj1 obj2 quot -- curry )
|
||||
curry curry ; inline
|
||||
|
||||
: 3curry ( obj1 obj2 obj3 quot -- curry )
|
||||
curry curry curry ; inline
|
||||
|
||||
: with ( param obj quot -- obj curry )
|
||||
swapd [ swapd call ] 2curry ; inline
|
||||
|
||||
: 3compose ( quot1 quot2 quot3 -- curry )
|
||||
compose compose ; inline
|
||||
|
||||
! Booleans
|
||||
: not ( obj -- ? ) f eq? ; inline
|
||||
|
||||
: >boolean ( obj -- ? ) t f ? ; inline
|
||||
|
|
|
|||
|
|
@ -11,12 +11,11 @@ classes.algebra optimizer.def-use optimizer.backend
|
|||
optimizer.pattern-match optimizer.inlining float-arrays
|
||||
sequences.private combinators ;
|
||||
|
||||
! the output of <tuple> and <tuple-boa> has the class which is
|
||||
! its second-to-last input
|
||||
{ <tuple> <tuple-boa> } [
|
||||
[
|
||||
dup node-in-d dup length 2 - swap nth node-literal
|
||||
dup class? [ drop tuple ] unless 1array f
|
||||
dup node-in-d peek node-literal
|
||||
dup tuple-layout? [ layout-class ] [ drop tuple ] if
|
||||
1array f
|
||||
] "output-classes" set-word-prop
|
||||
] each
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
|
|||
generic hashtables io assocs kernel math namespaces sequences
|
||||
strings sbufs io.styles vectors words prettyprint.config
|
||||
prettyprint.sections quotations io io.files math.parser effects
|
||||
tuples classes float-arrays float-vectors ;
|
||||
tuples tuples.private classes float-arrays float-vectors ;
|
||||
IN: prettyprint.backend
|
||||
|
||||
GENERIC: pprint* ( obj -- )
|
||||
|
|
@ -202,3 +202,6 @@ M: wrapper pprint*
|
|||
] [
|
||||
pprint-object
|
||||
] if ;
|
||||
|
||||
M: tuple-layout pprint*
|
||||
"( tuple layout )" swap present-text ;
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@ IN: quotations
|
|||
|
||||
M: quotation call (call) ;
|
||||
|
||||
M: curry call dup 4 slot swap 5 slot call ;
|
||||
M: curry call dup 3 slot swap 4 slot call ;
|
||||
|
||||
M: compose call dup 4 slot swap 5 slot slip call ;
|
||||
M: compose call dup 3 slot swap 4 slot slip call ;
|
||||
|
||||
M: wrapper equal?
|
||||
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ ARTICLE: "accessors" "Slot accessors"
|
|||
}
|
||||
"In addition, two utility words are defined for each distinct slot name used in the system:"
|
||||
{ $list
|
||||
{ "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
|
||||
{ "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
|
||||
{ "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
|
||||
}
|
||||
"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ C: <slot-spec> slot-spec
|
|||
: define-writer ( class slot name -- )
|
||||
writer-word [ set-slot ] define-slot-word ;
|
||||
|
||||
: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
|
||||
: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline
|
||||
|
||||
: setter-word ( name -- word )
|
||||
">>" prepend setter-effect create-accessor ;
|
||||
|
|
|
|||
|
|
@ -153,10 +153,6 @@ HELP: tuple=
|
|||
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
|
||||
{ $warning "This word is in the " { $vocab-link "tuples.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
|
||||
|
||||
HELP: tuple-class-eq?
|
||||
{ $values { "obj" object } { "class" tuple-class } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "obj" } " is an instance of " { $snippet "class" } "." } ;
|
||||
|
||||
HELP: permutation
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
|
||||
{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
|
||||
|
|
@ -246,9 +242,13 @@ HELP: tuple>array ( tuple -- array )
|
|||
{ $values { "tuple" tuple } { "array" array } }
|
||||
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
|
||||
|
||||
HELP: <tuple> ( class n -- tuple )
|
||||
{ $values { "class" tuple-class } { "n" "a non-negative integer" } { "tuple" tuple } }
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use the constructor word which is defined for each tuple. See " { $link "tuples" } "." } ;
|
||||
HELP: <tuple> ( layout -- tuple )
|
||||
{ $values { "layout" tuple-layout } { "tuple" tuple } }
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
|
||||
|
||||
HELP: <tuple-boa> ( ... layout -- tuple )
|
||||
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
|
||||
|
||||
HELP: construct-empty
|
||||
{ $values { "class" tuple-class } { "tuple" tuple } }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays definitions hashtables kernel
|
||||
kernel.private math namespaces sequences sequences.private
|
||||
|
|
@ -7,33 +7,55 @@ classes classes.private slots slots.deprecated slots.private
|
|||
compiler.units ;
|
||||
IN: tuples
|
||||
|
||||
M: tuple delegate 3 slot ;
|
||||
M: tuple delegate 2 slot ;
|
||||
|
||||
M: tuple set-delegate 3 set-slot ;
|
||||
M: tuple set-delegate 2 set-slot ;
|
||||
|
||||
M: tuple class class-of-tuple ;
|
||||
M: tuple class 1 slot 2 slot { word } declare ;
|
||||
|
||||
ERROR: no-tuple-class class ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tuple-size tuple-layout layout-size ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: check-tuple ( class -- )
|
||||
dup tuple-class?
|
||||
[ drop ] [ no-tuple-class ] if ;
|
||||
|
||||
: tuple>array ( tuple -- array )
|
||||
dup tuple-layout
|
||||
[ layout-size swap [ array-nth ] curry map ] keep
|
||||
layout-class add* ;
|
||||
|
||||
: >tuple ( sequence -- tuple )
|
||||
dup first tuple-layout <tuple> [
|
||||
>r 1 tail-slice dup length r>
|
||||
[ tuple-size min ] keep
|
||||
[ set-array-nth ] curry
|
||||
2each
|
||||
] keep ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tuple= ( tuple1 tuple2 -- ? )
|
||||
over array-capacity over array-capacity tuck number= [
|
||||
-rot
|
||||
over tuple-layout over tuple-layout eq? [
|
||||
dup tuple-size -rot
|
||||
[ >r over r> array-nth >r array-nth r> = ] 2curry
|
||||
all-integers?
|
||||
] [
|
||||
3drop f
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: tuple-class-eq? ( obj class -- ? )
|
||||
over tuple? [ swap 2 slot eq? ] [ 2drop f ] if ; inline
|
||||
|
||||
: permutation ( seq1 seq2 -- permutation )
|
||||
swap [ index ] curry map ;
|
||||
|
||||
: reshape-tuple ( oldtuple permutation -- newtuple )
|
||||
>r tuple>array 2 cut r>
|
||||
[ [ swap ?nth ] [ drop f ] if* ] with map
|
||||
append (>tuple) ;
|
||||
append >tuple ;
|
||||
|
||||
: reshape-tuples ( class newslots -- )
|
||||
>r dup "slot-names" word-prop r> permutation
|
||||
|
|
@ -64,42 +86,42 @@ M: tuple class class-of-tuple ;
|
|||
] unless
|
||||
] when 2drop ;
|
||||
|
||||
GENERIC: tuple-size ( class -- size )
|
||||
|
||||
M: tuple-class tuple-size "slot-names" word-prop length 2 + ;
|
||||
|
||||
PRIVATE>
|
||||
M: tuple-class tuple-layout "layout" word-prop ;
|
||||
|
||||
: define-tuple-predicate ( class -- )
|
||||
dup [ tuple-class-eq? ] curry define-predicate ;
|
||||
dup tuple-layout
|
||||
[ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry
|
||||
define-predicate ;
|
||||
|
||||
: delegate-slot-spec
|
||||
T{ slot-spec f
|
||||
object
|
||||
"delegate"
|
||||
3
|
||||
2
|
||||
delegate
|
||||
set-delegate
|
||||
} ;
|
||||
|
||||
: define-tuple-slots ( class slots -- )
|
||||
dupd 4 simple-slots
|
||||
dupd 3 simple-slots
|
||||
2dup [ slot-spec-name ] map "slot-names" set-word-prop
|
||||
2dup delegate-slot-spec add* "slots" set-word-prop
|
||||
2dup define-slots
|
||||
define-accessors ;
|
||||
|
||||
ERROR: no-tuple-class class ;
|
||||
: define-tuple-layout ( class -- )
|
||||
dup
|
||||
dup "slot-names" word-prop length 1+ { } 0 <tuple-layout>
|
||||
"layout" set-word-prop ;
|
||||
|
||||
: check-tuple ( class -- )
|
||||
dup tuple-class?
|
||||
[ drop ] [ no-tuple-class ] if ;
|
||||
PRIVATE>
|
||||
|
||||
: define-tuple-class ( class slots -- )
|
||||
2dup check-shape
|
||||
over f tuple tuple-class define-class
|
||||
over define-tuple-predicate
|
||||
define-tuple-slots ;
|
||||
dupd define-tuple-slots
|
||||
dup define-tuple-layout
|
||||
define-tuple-predicate ;
|
||||
|
||||
M: tuple clone
|
||||
(clone) dup delegate clone over set-delegate ;
|
||||
|
|
@ -107,21 +129,14 @@ M: tuple clone
|
|||
M: tuple equal?
|
||||
over tuple? [ tuple= ] [ 2drop f ] if ;
|
||||
|
||||
: (delegates) ( obj -- )
|
||||
[ dup , delegate (delegates) ] when* ;
|
||||
|
||||
: delegates ( obj -- seq )
|
||||
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
|
||||
|
||||
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
|
||||
|
||||
: >tuple ( seq -- tuple )
|
||||
>vector dup first tuple-size over set-length
|
||||
>array (>tuple) ;
|
||||
|
||||
M: tuple hashcode*
|
||||
[
|
||||
dup array-capacity -rot 0 -rot [
|
||||
dup tuple-size -rot 0 -rot [
|
||||
swapd array-nth hashcode* bitxor
|
||||
] 2curry reduce
|
||||
] recursive-hashcode ;
|
||||
|
|
@ -131,7 +146,7 @@ M: tuple hashcode*
|
|||
! Definition protocol
|
||||
M: tuple-class reset-class
|
||||
{
|
||||
"metaclass" "superclass" "slot-names" "slots"
|
||||
"metaclass" "superclass" "slot-names" "slots" "layout"
|
||||
} reset-props ;
|
||||
|
||||
M: object get-slots ( obj slots -- ... )
|
||||
|
|
@ -141,10 +156,10 @@ M: object set-slots ( ... obj slots -- )
|
|||
<reversed> get-slots ;
|
||||
|
||||
M: object construct-empty ( class -- tuple )
|
||||
dup tuple-size <tuple> ;
|
||||
tuple-layout <tuple> ;
|
||||
|
||||
M: object construct ( ... slots class -- tuple )
|
||||
construct-empty [ swap set-slots ] keep ;
|
||||
|
||||
M: object construct-boa ( ... class -- tuple )
|
||||
dup tuple-size <tuple-boa> ;
|
||||
tuple-layout <tuple-boa> ;
|
||||
|
|
|
|||
|
|
@ -155,7 +155,6 @@ IN: tools.deploy.shaker
|
|||
layouts:tag-numbers
|
||||
layouts:type-numbers
|
||||
lexer-factory
|
||||
lexer-factory
|
||||
listener:listener-hook
|
||||
root-cache
|
||||
vocab-roots
|
||||
|
|
|
|||
10
vm/data_gc.c
10
vm/data_gc.c
|
|
@ -156,10 +156,12 @@ CELL untagged_object_size(CELL pointer)
|
|||
/* Size of the data area of an object pointed to by an untagged pointer */
|
||||
CELL unaligned_object_size(CELL pointer)
|
||||
{
|
||||
F_TUPLE *tuple;
|
||||
F_TUPLE_LAYOUT *layout;
|
||||
|
||||
switch(untag_header(get(pointer)))
|
||||
{
|
||||
case ARRAY_TYPE:
|
||||
case TUPLE_TYPE:
|
||||
case BIGNUM_TYPE:
|
||||
return array_size(array_capacity((F_ARRAY*)pointer));
|
||||
case BYTE_ARRAY_TYPE:
|
||||
|
|
@ -173,6 +175,10 @@ CELL unaligned_object_size(CELL pointer)
|
|||
float_array_capacity((F_FLOAT_ARRAY*)pointer));
|
||||
case STRING_TYPE:
|
||||
return string_size(string_capacity((F_STRING*)pointer));
|
||||
case TUPLE_TYPE:
|
||||
tuple = untag_object(pointer);
|
||||
layout = untag_object(tuple->layout);
|
||||
return tuple_size(layout);
|
||||
case QUOTATION_TYPE:
|
||||
return sizeof(F_QUOTATION);
|
||||
case WORD_TYPE:
|
||||
|
|
@ -192,6 +198,8 @@ CELL unaligned_object_size(CELL pointer)
|
|||
case CALLSTACK_TYPE:
|
||||
return callstack_size(
|
||||
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
|
||||
case TUPLE_LAYOUT_TYPE:
|
||||
return sizeof(F_TUPLE_LAYOUT);
|
||||
default:
|
||||
critical_error("Invalid header",pointer);
|
||||
return -1; /* can't happen */
|
||||
|
|
|
|||
31
vm/debug.c
31
vm/debug.c
|
|
@ -57,6 +57,35 @@ void print_array(F_ARRAY* array, CELL nesting)
|
|||
printf("...");
|
||||
}
|
||||
|
||||
void print_tuple(F_TUPLE* tuple, CELL nesting)
|
||||
{
|
||||
F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
|
||||
CELL length = to_fixnum(layout->size);
|
||||
|
||||
printf(" ");
|
||||
print_nested_obj(layout->class,nesting);
|
||||
|
||||
CELL i;
|
||||
bool trimmed;
|
||||
|
||||
if(length > 10)
|
||||
{
|
||||
trimmed = true;
|
||||
length = 10;
|
||||
}
|
||||
else
|
||||
trimmed = false;
|
||||
|
||||
for(i = 0; i < length; i++)
|
||||
{
|
||||
printf(" ");
|
||||
print_nested_obj(tuple_nth(tuple,i),nesting);
|
||||
}
|
||||
|
||||
if(trimmed)
|
||||
printf("...");
|
||||
}
|
||||
|
||||
void print_nested_obj(CELL obj, F_FIXNUM nesting)
|
||||
{
|
||||
if(nesting <= 0)
|
||||
|
|
@ -83,7 +112,7 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting)
|
|||
break;
|
||||
case TUPLE_TYPE:
|
||||
printf("T{");
|
||||
print_array(untag_object(obj),nesting - 1);
|
||||
print_tuple(untag_object(obj),nesting - 1);
|
||||
printf(" }");
|
||||
break;
|
||||
case ARRAY_TYPE:
|
||||
|
|
|
|||
56
vm/image.c
56
vm/image.c
|
|
@ -216,25 +216,45 @@ void fixup_callstack_object(F_CALLSTACK *stack)
|
|||
/* Initialize an object in a newly-loaded image */
|
||||
void relocate_object(CELL relocating)
|
||||
{
|
||||
do_slots(relocating,data_fixup);
|
||||
|
||||
switch(untag_header(get(relocating)))
|
||||
/* Tuple relocation is a bit trickier; we have to fix up the
|
||||
fixup object before we can get the tuple size, so do_slots is
|
||||
out of the question */
|
||||
if(untag_header(get(relocating)) == TUPLE_TYPE)
|
||||
{
|
||||
case WORD_TYPE:
|
||||
fixup_word((F_WORD *)relocating);
|
||||
break;
|
||||
case QUOTATION_TYPE:
|
||||
fixup_quotation((F_QUOTATION *)relocating);
|
||||
break;
|
||||
case DLL_TYPE:
|
||||
ffi_dlopen((F_DLL *)relocating);
|
||||
break;
|
||||
case ALIEN_TYPE:
|
||||
fixup_alien((F_ALIEN *)relocating);
|
||||
break;
|
||||
case CALLSTACK_TYPE:
|
||||
fixup_callstack_object((F_CALLSTACK *)relocating);
|
||||
break;
|
||||
data_fixup((CELL *)relocating + 1);
|
||||
|
||||
CELL scan = relocating + 2 * CELLS;
|
||||
CELL size = untagged_object_size(relocating);
|
||||
CELL end = relocating + size;
|
||||
|
||||
while(scan < end)
|
||||
{
|
||||
data_fixup((CELL *)scan);
|
||||
scan += CELLS;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
do_slots(relocating,data_fixup);
|
||||
|
||||
switch(untag_header(get(relocating)))
|
||||
{
|
||||
case WORD_TYPE:
|
||||
fixup_word((F_WORD *)relocating);
|
||||
break;
|
||||
case QUOTATION_TYPE:
|
||||
fixup_quotation((F_QUOTATION *)relocating);
|
||||
break;
|
||||
case DLL_TYPE:
|
||||
ffi_dlopen((F_DLL *)relocating);
|
||||
break;
|
||||
case ALIEN_TYPE:
|
||||
fixup_alien((F_ALIEN *)relocating);
|
||||
break;
|
||||
case CALLSTACK_TYPE:
|
||||
fixup_callstack_object((F_CALLSTACK *)relocating);
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
25
vm/layouts.h
25
vm/layouts.h
|
|
@ -58,8 +58,9 @@ typedef signed long long s64;
|
|||
#define ALIEN_TYPE 16
|
||||
#define WORD_TYPE 17
|
||||
#define BYTE_ARRAY_TYPE 18
|
||||
#define TUPLE_LAYOUT_TYPE 19
|
||||
|
||||
#define TYPE_COUNT 19
|
||||
#define TYPE_COUNT 20
|
||||
|
||||
INLINE bool immediate_p(CELL obj)
|
||||
{
|
||||
|
|
@ -224,3 +225,25 @@ typedef struct
|
|||
/* Frame size in bytes */
|
||||
CELL size;
|
||||
} F_STACK_FRAME;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
CELL header;
|
||||
/* tagged fixnum */
|
||||
CELL hashcode;
|
||||
/* tagged */
|
||||
CELL class;
|
||||
/* tagged fixnum */
|
||||
CELL size;
|
||||
/* tagged array */
|
||||
CELL superclasses;
|
||||
/* tagged fixnum */
|
||||
CELL echelon;
|
||||
} F_TUPLE_LAYOUT;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
CELL header;
|
||||
/* tagged layout */
|
||||
CELL layout;
|
||||
} F_TUPLE;
|
||||
|
|
|
|||
|
|
@ -169,11 +169,10 @@ void *primitives[] = {
|
|||
primitive_wrapper,
|
||||
primitive_clone,
|
||||
primitive_string,
|
||||
primitive_to_tuple,
|
||||
primitive_array_to_quotation,
|
||||
primitive_quotation_xt,
|
||||
primitive_tuple,
|
||||
primitive_tuple_to_array,
|
||||
primitive_tuple_layout,
|
||||
primitive_profiling,
|
||||
primitive_become,
|
||||
primitive_sleep,
|
||||
|
|
|
|||
5
vm/run.c
5
vm/run.c
|
|
@ -320,8 +320,9 @@ DEFINE_PRIMITIVE(class_hash)
|
|||
CELL tag = TAG(obj);
|
||||
if(tag == TUPLE_TYPE)
|
||||
{
|
||||
F_WORD *class = untag_object(get(SLOT(obj,2)));
|
||||
drepl(class->hashcode);
|
||||
F_TUPLE *tuple = untag_object(obj);
|
||||
F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
|
||||
drepl(layout->hashcode);
|
||||
}
|
||||
else if(tag == OBJECT_TYPE)
|
||||
drepl(get(UNTAG(obj)));
|
||||
|
|
|
|||
66
vm/types.c
66
vm/types.c
|
|
@ -379,45 +379,61 @@ DEFINE_PRIMITIVE(resize_float_array)
|
|||
dpush(tag_object(reallot_float_array(array,capacity)));
|
||||
}
|
||||
|
||||
/* Tuple layouts */
|
||||
DEFINE_PRIMITIVE(tuple_layout)
|
||||
{
|
||||
F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT));
|
||||
layout->echelon = dpop();
|
||||
layout->superclasses = dpop();
|
||||
layout->size = dpop();
|
||||
layout->class = dpop();
|
||||
layout->hashcode = untag_word(layout->class)->hashcode;
|
||||
dpush(tag_object(layout));
|
||||
}
|
||||
|
||||
/* Tuples */
|
||||
|
||||
/* push a new tuple on the stack */
|
||||
F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
|
||||
{
|
||||
REGISTER_UNTAGGED(layout);
|
||||
F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
|
||||
UNREGISTER_UNTAGGED(layout);
|
||||
tuple->layout = tag_object(layout);
|
||||
return tuple;
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(tuple)
|
||||
{
|
||||
CELL size = unbox_array_size();
|
||||
F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
|
||||
set_array_nth(array,0,dpop());
|
||||
dpush(tag_tuple(array));
|
||||
F_TUPLE_LAYOUT *layout = untag_object(dpop());
|
||||
F_FIXNUM size = to_fixnum(layout->size);
|
||||
|
||||
F_TUPLE *tuple = allot_tuple(layout);
|
||||
F_FIXNUM i;
|
||||
for(i = size - 1; i >= 0; i--)
|
||||
put(AREF(tuple,i),F);
|
||||
|
||||
dpush(tag_tuple(tuple));
|
||||
}
|
||||
|
||||
/* push a new tuple on the stack, filling its slots from the stack */
|
||||
DEFINE_PRIMITIVE(tuple_boa)
|
||||
{
|
||||
CELL size = unbox_array_size();
|
||||
F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
|
||||
set_array_nth(array,0,dpop());
|
||||
F_TUPLE_LAYOUT *layout = untag_object(dpop());
|
||||
F_FIXNUM size = to_fixnum(layout->size);
|
||||
|
||||
CELL i;
|
||||
for(i = size - 1; i >= 2; i--)
|
||||
set_array_nth(array,i,dpop());
|
||||
REGISTER_UNTAGGED(layout);
|
||||
F_TUPLE *tuple = allot_tuple(layout);
|
||||
UNREGISTER_UNTAGGED(layout);
|
||||
|
||||
dpush(tag_tuple(array));
|
||||
}
|
||||
/* set delegate slot */
|
||||
put(AREF(tuple,0),F);
|
||||
|
||||
DEFINE_PRIMITIVE(tuple_to_array)
|
||||
{
|
||||
CELL object = dpeek();
|
||||
type_check(TUPLE_TYPE,object);
|
||||
object = RETAG(clone(object),OBJECT_TYPE);
|
||||
set_slot(object,0,tag_header(ARRAY_TYPE));
|
||||
drepl(object);
|
||||
}
|
||||
F_FIXNUM i;
|
||||
for(i = size - 1; i >= 1; i--)
|
||||
put(AREF(tuple,i),dpop());
|
||||
|
||||
DEFINE_PRIMITIVE(to_tuple)
|
||||
{
|
||||
CELL object = RETAG(clone(dpeek()),TUPLE_TYPE);
|
||||
set_slot(object,0,tag_header(TUPLE_TYPE));
|
||||
drepl(object);
|
||||
dpush(tag_tuple(tuple));
|
||||
}
|
||||
|
||||
/* Strings */
|
||||
|
|
|
|||
28
vm/types.h
28
vm/types.h
|
|
@ -96,11 +96,34 @@ DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
|
|||
|
||||
DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
|
||||
|
||||
INLINE CELL tag_tuple(F_ARRAY *tuple)
|
||||
INLINE CELL tag_tuple(F_TUPLE *tuple)
|
||||
{
|
||||
return RETAG(tuple,TUPLE_TYPE);
|
||||
}
|
||||
|
||||
INLINE F_TUPLE *untag_tuple(CELL object)
|
||||
{
|
||||
type_check(TUPLE_TYPE,object);
|
||||
return untag_object(object);
|
||||
}
|
||||
|
||||
INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
|
||||
{
|
||||
CELL size = untag_fixnum_fast(layout->size);
|
||||
return sizeof(F_TUPLE) + size * CELLS;
|
||||
}
|
||||
|
||||
INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
|
||||
{
|
||||
return get(AREF(tuple,slot));
|
||||
}
|
||||
|
||||
INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
|
||||
{
|
||||
put(AREF(tuple,slot),value);
|
||||
write_barrier((CELL)tuple);
|
||||
}
|
||||
|
||||
/* Prototypes */
|
||||
DLLEXPORT void box_boolean(bool value);
|
||||
DLLEXPORT bool to_boolean(CELL value);
|
||||
|
|
@ -116,12 +139,11 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
|
|||
DECLARE_PRIMITIVE(array);
|
||||
DECLARE_PRIMITIVE(tuple);
|
||||
DECLARE_PRIMITIVE(tuple_boa);
|
||||
DECLARE_PRIMITIVE(tuple_layout);
|
||||
DECLARE_PRIMITIVE(byte_array);
|
||||
DECLARE_PRIMITIVE(bit_array);
|
||||
DECLARE_PRIMITIVE(float_array);
|
||||
DECLARE_PRIMITIVE(clone);
|
||||
DECLARE_PRIMITIVE(tuple_to_array);
|
||||
DECLARE_PRIMITIVE(to_tuple);
|
||||
|
||||
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
|
||||
DECLARE_PRIMITIVE(resize_array);
|
||||
|
|
|
|||
Loading…
Reference in New Issue