Converting code to use inheritance
Slava Pestov
parent
76581ad6d0
commit
ef4046cda9
|
|
@ -62,22 +62,16 @@ TUPLE: library path abi dll ;
|
|||
: add-library ( name path abi -- )
|
||||
<library> swap libraries get set-at ;
|
||||
|
||||
TUPLE: alien-callback return parameters abi quot xt ;
|
||||
|
||||
ERROR: alien-callback-error ;
|
||||
|
||||
: alien-callback ( return parameters abi quot -- alien )
|
||||
alien-callback-error ;
|
||||
|
||||
TUPLE: alien-indirect return parameters abi ;
|
||||
|
||||
ERROR: alien-indirect-error ;
|
||||
|
||||
: alien-indirect ( ... funcptr return parameters abi -- )
|
||||
alien-indirect-error ;
|
||||
|
||||
TUPLE: alien-invoke library function return parameters abi ;
|
||||
|
||||
ERROR: alien-invoke-error library symbol ;
|
||||
|
||||
: alien-invoke ( ... return library function parameters -- ... )
|
||||
|
|
|
|||
|
|
@ -9,6 +9,14 @@ kernel.private threads continuations.private libc combinators
|
|||
compiler.errors continuations layouts accessors ;
|
||||
IN: alien.compiler
|
||||
|
||||
TUPLE: #alien-node < node return parameters abi ;
|
||||
|
||||
TUPLE: #alien-callback < #alien-node quot xt ;
|
||||
|
||||
TUPLE: #alien-indirect < #alien-node ;
|
||||
|
||||
TUPLE: #alien-invoke < #alien-node library function ;
|
||||
|
||||
: large-struct? ( ctype -- ? )
|
||||
dup c-struct? [
|
||||
heap-size struct-small-enough? not
|
||||
|
|
@ -229,32 +237,32 @@ M: no-such-symbol compiler-error-type
|
|||
] if ;
|
||||
|
||||
: alien-invoke-dlsym ( node -- symbols dll )
|
||||
dup alien-invoke-function dup pick stdcall-mangle 2array
|
||||
swap alien-invoke-library library dup [ library-dll ] when
|
||||
dup function>> dup pick stdcall-mangle 2array
|
||||
swap library>> library dup [ dll>> ] when
|
||||
2dup check-dlsym ;
|
||||
|
||||
\ alien-invoke [
|
||||
! Four literals
|
||||
4 ensure-values
|
||||
\ alien-invoke empty-node
|
||||
#alien-invoke construct-empty
|
||||
! Compile-time parameters
|
||||
pop-parameters over set-alien-invoke-parameters
|
||||
pop-literal nip over set-alien-invoke-function
|
||||
pop-literal nip over set-alien-invoke-library
|
||||
pop-literal nip over set-alien-invoke-return
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>function
|
||||
pop-literal nip >>library
|
||||
pop-literal nip >>return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup make-prep-quot recursive-state get infer-quot
|
||||
! Set ABI
|
||||
dup alien-invoke-library
|
||||
library [ library-abi ] [ "cdecl" ] if*
|
||||
over set-alien-invoke-abi
|
||||
dup library>>
|
||||
library [ abi>> ] [ "cdecl" ] if*
|
||||
>>abi
|
||||
! Add node to IR
|
||||
dup node,
|
||||
! Magic #: consume exactly the number of inputs
|
||||
0 alien-invoke-stack
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: alien-invoke generate-node
|
||||
M: #alien-invoke generate-node
|
||||
dup alien-invoke-frame [
|
||||
end-basic-block
|
||||
%prepare-alien-invoke
|
||||
|
|
@ -273,11 +281,11 @@ M: alien-indirect-error summary
|
|||
! Three literals and function pointer
|
||||
4 ensure-values
|
||||
4 reify-curries
|
||||
\ alien-indirect empty-node
|
||||
#alien-indirect construct-empty
|
||||
! Compile-time parameters
|
||||
pop-literal nip over set-alien-indirect-abi
|
||||
pop-parameters over set-alien-indirect-parameters
|
||||
pop-literal nip over set-alien-indirect-return
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
|
||||
! Add node to IR
|
||||
|
|
@ -286,7 +294,7 @@ M: alien-indirect-error summary
|
|||
1 alien-invoke-stack
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: alien-indirect generate-node
|
||||
M: #alien-indirect generate-node
|
||||
dup alien-invoke-frame [
|
||||
! Flush registers
|
||||
end-basic-block
|
||||
|
|
@ -320,12 +328,12 @@ M: alien-callback-error summary
|
|||
|
||||
\ alien-callback [
|
||||
4 ensure-values
|
||||
\ alien-callback empty-node dup node,
|
||||
pop-literal nip over set-alien-callback-quot
|
||||
pop-literal nip over set-alien-callback-abi
|
||||
pop-parameters over set-alien-callback-parameters
|
||||
pop-literal nip over set-alien-callback-return
|
||||
gensym dup register-callback over set-alien-callback-xt
|
||||
#alien-callback construct-empty dup node,
|
||||
pop-literal nip >>quot
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>return
|
||||
gensym dup register-callback >>xt
|
||||
callback-bottom
|
||||
] "infer" set-word-prop
|
||||
|
||||
|
|
@ -398,5 +406,5 @@ TUPLE: callback-context ;
|
|||
] with-stack-frame
|
||||
] with-generator ;
|
||||
|
||||
M: alien-callback generate-node
|
||||
M: #alien-callback generate-node
|
||||
end-basic-block generate-callback iterate-next ;
|
||||
|
|
|
|||
|
|
@ -37,8 +37,6 @@ nl
|
|||
|
||||
wrap probe
|
||||
|
||||
delegate
|
||||
|
||||
underlying
|
||||
|
||||
find-pair-next namestack*
|
||||
|
|
|
|||
|
|
@ -68,13 +68,13 @@ UNION: c a b ;
|
|||
[ t ] [ \ tuple-class \ class class< ] unit-test
|
||||
[ f ] [ \ class \ tuple-class class< ] unit-test
|
||||
|
||||
TUPLE: delegate-clone ;
|
||||
TUPLE: tuple-example ;
|
||||
|
||||
[ t ] [ \ null \ delegate-clone class< ] unit-test
|
||||
[ f ] [ \ object \ delegate-clone class< ] unit-test
|
||||
[ f ] [ \ object \ delegate-clone class< ] unit-test
|
||||
[ t ] [ \ delegate-clone \ tuple class< ] unit-test
|
||||
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
|
||||
[ t ] [ \ null \ tuple-example class< ] unit-test
|
||||
[ f ] [ \ object \ tuple-example class< ] unit-test
|
||||
[ f ] [ \ object \ tuple-example class< ] unit-test
|
||||
[ t ] [ \ tuple-example \ tuple class< ] unit-test
|
||||
[ f ] [ \ tuple \ tuple-example class< ] unit-test
|
||||
|
||||
TUPLE: a1 ;
|
||||
TUPLE: b1 ;
|
||||
|
|
|
|||
|
|
@ -121,6 +121,7 @@ $nl
|
|||
"..."
|
||||
"TUPLE: shape color ... ;"
|
||||
}
|
||||
"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships."
|
||||
{ $heading "Anti-pattern #2: subclassing for implementation sharing only" }
|
||||
"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used."
|
||||
$nl
|
||||
|
|
@ -237,15 +238,6 @@ $nl
|
|||
|
||||
ABOUT: "tuples"
|
||||
|
||||
HELP: delegate
|
||||
{ $values { "obj" object } { "delegate" object } }
|
||||
{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." }
|
||||
{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ;
|
||||
|
||||
HELP: set-delegate
|
||||
{ $values { "delegate" object } { "tuple" tuple } }
|
||||
{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ;
|
||||
|
||||
HELP: tuple=
|
||||
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
|
||||
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
|
||||
|
|
@ -299,26 +291,16 @@ HELP: define-tuple-class
|
|||
|
||||
{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
|
||||
|
||||
HELP: delegates
|
||||
{ $values { "obj" object } { "seq" sequence } }
|
||||
{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
|
||||
|
||||
HELP: is?
|
||||
{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
|
||||
{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
|
||||
$nl
|
||||
"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
|
||||
|
||||
HELP: >tuple
|
||||
{ $values { "seq" sequence } { "tuple" tuple } }
|
||||
{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots."
|
||||
{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots."
|
||||
$nl
|
||||
"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
|
||||
{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
|
||||
|
||||
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." } ;
|
||||
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
|
||||
|
||||
HELP: <tuple> ( layout -- tuple )
|
||||
{ $values { "layout" tuple-layout } { "tuple" tuple } }
|
||||
|
|
|
|||
|
|
@ -16,25 +16,6 @@ TUPLE: rect x y w h ;
|
|||
|
||||
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
|
||||
|
||||
GENERIC: delegation-test
|
||||
M: object delegation-test drop 3 ;
|
||||
TUPLE: quux-tuple ;
|
||||
: <quux-tuple> quux-tuple construct-empty ;
|
||||
M: quux-tuple delegation-test drop 4 ;
|
||||
TUPLE: quuux-tuple ;
|
||||
: <quuux-tuple> { set-delegate } quuux-tuple construct ;
|
||||
|
||||
[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
|
||||
|
||||
GENERIC: delegation-test-2
|
||||
TUPLE: quux-tuple-2 ;
|
||||
: <quux-tuple-2> quux-tuple-2 construct-empty ;
|
||||
M: quux-tuple-2 delegation-test-2 drop 4 ;
|
||||
TUPLE: quuux-tuple-2 ;
|
||||
: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
|
||||
|
||||
[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
|
||||
|
||||
! Make sure we handle tuple class redefinition
|
||||
TUPLE: redefinition-test ;
|
||||
|
||||
|
|
@ -102,11 +83,6 @@ C: <empty> empty
|
|||
|
||||
[ t ] [ <empty> hashcode fixnum? ] unit-test
|
||||
|
||||
TUPLE: delegate-clone ;
|
||||
|
||||
[ T{ delegate-clone T{ empty f } } ]
|
||||
[ T{ delegate-clone T{ empty f } } clone ] unit-test
|
||||
|
||||
! Compiler regression
|
||||
[ t length ] [ object>> t eq? ] must-fail-with
|
||||
|
||||
|
|
|
|||
|
|
@ -22,11 +22,3 @@ TUPLE: color red green blue ;
|
|||
|
||||
[ T{ color f f f f } ]
|
||||
[ [ color construct-empty ] compile-call ] unit-test
|
||||
|
||||
[ T{ color "a" f "b" f } ] [
|
||||
"a" "b"
|
||||
[ { set-delegate set-color-green } color construct ]
|
||||
compile-call
|
||||
] unit-test
|
||||
|
||||
[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -141,14 +141,9 @@ GENERIC: dispose ( object -- )
|
|||
: with-disposal ( object quot -- )
|
||||
over [ dispose ] curry [ ] cleanup ; inline
|
||||
|
||||
TUPLE: condition restarts continuation ;
|
||||
TUPLE: condition error restarts continuation ;
|
||||
|
||||
: <condition> ( error restarts cc -- condition )
|
||||
{
|
||||
set-delegate
|
||||
set-condition-restarts
|
||||
set-condition-continuation
|
||||
} condition construct ;
|
||||
C: <condition> condition ( error restarts cc -- condition )
|
||||
|
||||
: throw-restarts ( error restarts -- restart )
|
||||
[ <condition> throw ] callcc1 2nip ;
|
||||
|
|
@ -161,15 +156,14 @@ TUPLE: restart name obj continuation ;
|
|||
C: <restart> restart
|
||||
|
||||
: restart ( restart -- )
|
||||
dup restart-obj swap restart-continuation continue-with ;
|
||||
[ obj>> ] [ continuation>> ] bi continue-with ;
|
||||
|
||||
M: object compute-restarts drop { } ;
|
||||
|
||||
M: tuple compute-restarts delegate compute-restarts ;
|
||||
|
||||
M: condition compute-restarts
|
||||
[ delegate compute-restarts ] keep
|
||||
[ condition-restarts ] keep
|
||||
condition-continuation
|
||||
[ <restart> ] curry { } assoc>map
|
||||
append ;
|
||||
[ error>> compute-restarts ]
|
||||
[
|
||||
[ restarts>> ]
|
||||
[ condition-continuation [ <restart> ] curry ] bi
|
||||
{ } assoc>map
|
||||
] bi append ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
|
|||
classes.tuple continuations continuations.private combinators
|
||||
generic.math io.streams.duplex classes.builtin classes
|
||||
compiler.units generic.standard vocabs threads threads.private
|
||||
init kernel.private libc io.encodings ;
|
||||
init kernel.private libc io.encodings accessors ;
|
||||
IN: debugger
|
||||
|
||||
GENERIC: error. ( error -- )
|
||||
|
|
@ -202,6 +202,12 @@ M: no-method error.
|
|||
M: no-math-method summary
|
||||
drop "No suitable arithmetic method" ;
|
||||
|
||||
M: no-next-method summary
|
||||
drop "Executing call-next-method from least-specific method" ;
|
||||
|
||||
M: inconsistent-next-method summary
|
||||
drop "Executing call-next-method with inconsistent parameters" ;
|
||||
|
||||
M: stream-closed-twice summary
|
||||
drop "Attempt to perform I/O on closed stream" ;
|
||||
|
||||
|
|
@ -223,9 +229,11 @@ M: slice-error error.
|
|||
|
||||
M: bounds-error summary drop "Sequence index out of bounds" ;
|
||||
|
||||
M: condition error. delegate error. ;
|
||||
M: condition error. error>> error. ;
|
||||
|
||||
M: condition error-help drop f ;
|
||||
M: condition summary error>> summary ;
|
||||
|
||||
M: condition error-help error>> error-help ;
|
||||
|
||||
M: assert summary drop "Assertion failed" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ HELP: standard-combination
|
|||
{ $class-description
|
||||
"Performs standard method combination."
|
||||
$nl
|
||||
"Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. If no suitable method is defined on the class of the dispatch object, the generic word is called on the dispatch object's delegate. If the delegate is " { $link f } ", an exception is thrown."
|
||||
"Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. A " { $link no-method } " error is thrown if no suitable method is defined on the class."
|
||||
}
|
||||
{ $examples
|
||||
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: arrays kernel math namespaces tools.test
|
||||
heaps heaps.private math.parser random assocs sequences sorting ;
|
||||
heaps heaps.private math.parser random assocs sequences sorting
|
||||
accessors ;
|
||||
IN: heaps.tests
|
||||
|
||||
[ <min-heap> heap-pop ] must-fail
|
||||
|
|
@ -47,7 +48,7 @@ IN: heaps.tests
|
|||
: test-entry-indices ( n -- ? )
|
||||
random-alist
|
||||
<min-heap> [ heap-push-all ] keep
|
||||
heap-data dup length swap [ entry-index ] map sequence= ;
|
||||
data>> dup length swap [ entry-index ] map sequence= ;
|
||||
|
||||
14 [
|
||||
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
|
||||
|
|
@ -63,9 +64,9 @@ IN: heaps.tests
|
|||
[
|
||||
random-alist
|
||||
<min-heap> [ heap-push-all ] keep
|
||||
dup heap-data clone swap
|
||||
dup data>> clone swap
|
||||
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
|
||||
heap-data
|
||||
data>>
|
||||
[ [ entry-key ] map ] bi@
|
||||
[ natural-sort ] bi@ ;
|
||||
|
||||
|
|
|
|||
|
|
@ -17,10 +17,10 @@ GENERIC: heap-size ( heap -- n )
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: heap-data delegate ; inline
|
||||
TUPLE: heap data ;
|
||||
|
||||
: <heap> ( class -- heap )
|
||||
>r V{ } clone r> construct-delegate ; inline
|
||||
>r V{ } clone r> construct-boa ; inline
|
||||
|
||||
TUPLE: entry value key heap index ;
|
||||
|
||||
|
|
@ -28,11 +28,11 @@ TUPLE: entry value key heap index ;
|
|||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: min-heap ;
|
||||
TUPLE: min-heap < heap ;
|
||||
|
||||
: <min-heap> ( -- min-heap ) min-heap <heap> ;
|
||||
|
||||
TUPLE: max-heap ;
|
||||
TUPLE: max-heap < heap ;
|
||||
|
||||
: <max-heap> ( -- max-heap ) max-heap <heap> ;
|
||||
|
||||
|
|
@ -40,10 +40,10 @@ INSTANCE: min-heap priority-queue
|
|||
INSTANCE: max-heap priority-queue
|
||||
|
||||
M: priority-queue heap-empty? ( heap -- ? )
|
||||
heap-data empty? ;
|
||||
data>> empty? ;
|
||||
|
||||
M: priority-queue heap-size ( heap -- n )
|
||||
heap-data length ;
|
||||
data>> length ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -54,7 +54,7 @@ M: priority-queue heap-size ( heap -- n )
|
|||
: up ( n -- m ) 1- 2/ ; inline
|
||||
|
||||
: data-nth ( n heap -- entry )
|
||||
heap-data nth-unsafe ; inline
|
||||
data>> nth-unsafe ; inline
|
||||
|
||||
: up-value ( n heap -- entry )
|
||||
>r up r> data-nth ; inline
|
||||
|
|
@ -67,24 +67,24 @@ M: priority-queue heap-size ( heap -- n )
|
|||
|
||||
: data-set-nth ( entry n heap -- )
|
||||
>r [ swap set-entry-index ] 2keep r>
|
||||
heap-data set-nth-unsafe ;
|
||||
data>> set-nth-unsafe ;
|
||||
|
||||
: data-push ( entry heap -- n )
|
||||
dup heap-size [
|
||||
swap 2dup heap-data ensure 2drop data-set-nth
|
||||
swap 2dup data>> ensure 2drop data-set-nth
|
||||
] keep ; inline
|
||||
|
||||
: data-pop ( heap -- entry )
|
||||
heap-data pop ; inline
|
||||
data>> pop ; inline
|
||||
|
||||
: data-pop* ( heap -- )
|
||||
heap-data pop* ; inline
|
||||
data>> pop* ; inline
|
||||
|
||||
: data-peek ( heap -- entry )
|
||||
heap-data peek ; inline
|
||||
data>> peek ; inline
|
||||
|
||||
: data-first ( heap -- entry )
|
||||
heap-data first ; inline
|
||||
data>> first ; inline
|
||||
|
||||
: data-exchange ( m n heap -- )
|
||||
[ tuck data-nth >r data-nth r> ] 3keep
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
|
|||
io.streams.string kernel math namespaces parser prettyprint
|
||||
sequences strings vectors words quotations effects classes
|
||||
continuations debugger assocs combinators compiler.errors
|
||||
generic.standard.engines.tuple ;
|
||||
generic.standard.engines.tuple accessors ;
|
||||
IN: inference.backend
|
||||
|
||||
: recursive-label ( word -- label/f )
|
||||
|
|
@ -32,18 +32,14 @@ M: word inline?
|
|||
: recursive-quotation? ( quot -- ? )
|
||||
local-recursive-state [ first eq? ] with contains? ;
|
||||
|
||||
TUPLE: inference-error rstate type ;
|
||||
TUPLE: inference-error error type rstate ;
|
||||
|
||||
M: inference-error compiler-error-type
|
||||
inference-error-type ;
|
||||
M: inference-error compiler-error-type type>> ;
|
||||
|
||||
: (inference-error) ( ... class type -- * )
|
||||
>r construct-boa r>
|
||||
recursive-state get {
|
||||
set-delegate
|
||||
set-inference-error-type
|
||||
set-inference-error-rstate
|
||||
} \ inference-error construct throw ; inline
|
||||
recursive-state get
|
||||
\ inference-error construct-boa throw ; inline
|
||||
|
||||
: inference-error ( ... class -- * )
|
||||
+error+ (inference-error) ; inline
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs kernel math namespaces parser
|
||||
sequences words vectors math.intervals effects classes
|
||||
inference.state ;
|
||||
inference.state accessors combinators ;
|
||||
IN: inference.dataflow
|
||||
|
||||
! Computed value
|
||||
|
|
@ -39,12 +39,12 @@ M: node hashcode* drop node hashcode* ;
|
|||
GENERIC: flatten-curry ( value -- )
|
||||
|
||||
M: curried flatten-curry
|
||||
dup curried-obj flatten-curry
|
||||
curried-quot flatten-curry ;
|
||||
[ obj>> flatten-curry ]
|
||||
[ quot>> flatten-curry ] bi ;
|
||||
|
||||
M: composed flatten-curry
|
||||
dup composed-quot1 flatten-curry
|
||||
composed-quot2 flatten-curry ;
|
||||
[ quot1>> flatten-curry ]
|
||||
[ quot2>> flatten-curry ] bi ;
|
||||
|
||||
M: object flatten-curry , ;
|
||||
|
||||
|
|
@ -57,31 +57,27 @@ M: object flatten-curry , ;
|
|||
meta-d get clone flatten-curries ;
|
||||
|
||||
: modify-values ( node quot -- )
|
||||
[ swap [ node-in-d swap call ] keep set-node-in-d ] 2keep
|
||||
[ swap [ node-in-r swap call ] keep set-node-in-r ] 2keep
|
||||
[ swap [ node-out-d swap call ] keep set-node-out-d ] 2keep
|
||||
swap [ node-out-r swap call ] keep set-node-out-r ; inline
|
||||
{
|
||||
[ change-in-d ]
|
||||
[ change-in-r ]
|
||||
[ change-out-d ]
|
||||
[ change-out-r ]
|
||||
} cleave drop ; inline
|
||||
|
||||
: node-shuffle ( node -- shuffle )
|
||||
dup node-in-d swap node-out-d <effect> ;
|
||||
|
||||
: make-node ( slots class -- node )
|
||||
>r node construct r> construct-delegate ; inline
|
||||
|
||||
: empty-node ( class -- node )
|
||||
{ } swap make-node ; inline
|
||||
[ in-d>> ] [ out-d>> ] bi <effect> ;
|
||||
|
||||
: param-node ( param class -- node )
|
||||
{ set-node-param } swap make-node ; inline
|
||||
construct-empty swap >>param ; inline
|
||||
|
||||
: in-node ( seq class -- node )
|
||||
{ set-node-in-d } swap make-node ; inline
|
||||
construct-empty swap >>in-d ; inline
|
||||
|
||||
: all-in-node ( class -- node )
|
||||
flatten-meta-d swap in-node ; inline
|
||||
|
||||
: out-node ( seq class -- node )
|
||||
{ set-node-out-d } swap make-node ; inline
|
||||
construct-empty swap >>out-d ; inline
|
||||
|
||||
: all-out-node ( class -- node )
|
||||
flatten-meta-d swap out-node ; inline
|
||||
|
|
@ -94,81 +90,81 @@ M: object flatten-curry , ;
|
|||
|
||||
: node-child node-children first ;
|
||||
|
||||
TUPLE: #label word loop? ;
|
||||
TUPLE: #label < node word loop? ;
|
||||
|
||||
: #label ( word label -- node )
|
||||
\ #label param-node [ set-#label-word ] keep ;
|
||||
\ #label param-node swap >>word ;
|
||||
|
||||
PREDICATE: #loop < #label #label-loop? ;
|
||||
|
||||
TUPLE: #entry ;
|
||||
TUPLE: #entry < node ;
|
||||
|
||||
: #entry ( -- node ) \ #entry all-out-node ;
|
||||
|
||||
TUPLE: #call ;
|
||||
TUPLE: #call < node ;
|
||||
|
||||
: #call ( word -- node ) \ #call param-node ;
|
||||
|
||||
TUPLE: #call-label ;
|
||||
TUPLE: #call-label < node ;
|
||||
|
||||
: #call-label ( label -- node ) \ #call-label param-node ;
|
||||
|
||||
TUPLE: #push ;
|
||||
TUPLE: #push < node ;
|
||||
|
||||
: #push ( -- node ) \ #push empty-node ;
|
||||
: #push ( -- node ) \ #push construct-empty ;
|
||||
|
||||
TUPLE: #shuffle ;
|
||||
TUPLE: #shuffle < node ;
|
||||
|
||||
: #shuffle ( -- node ) \ #shuffle empty-node ;
|
||||
: #shuffle ( -- node ) \ #shuffle construct-empty ;
|
||||
|
||||
TUPLE: #>r ;
|
||||
TUPLE: #>r < node ;
|
||||
|
||||
: #>r ( -- node ) \ #>r empty-node ;
|
||||
: #>r ( -- node ) \ #>r construct-empty ;
|
||||
|
||||
TUPLE: #r> ;
|
||||
TUPLE: #r> < node ;
|
||||
|
||||
: #r> ( -- node ) \ #r> empty-node ;
|
||||
: #r> ( -- node ) \ #r> construct-empty ;
|
||||
|
||||
TUPLE: #values ;
|
||||
TUPLE: #values < node ;
|
||||
|
||||
: #values ( -- node ) \ #values all-in-node ;
|
||||
|
||||
TUPLE: #return ;
|
||||
TUPLE: #return < node ;
|
||||
|
||||
: #return ( label -- node )
|
||||
\ #return all-in-node [ set-node-param ] keep ;
|
||||
\ #return all-in-node swap >>param ;
|
||||
|
||||
TUPLE: #if ;
|
||||
TUPLE: #branch < node ;
|
||||
|
||||
TUPLE: #if < #branch ;
|
||||
|
||||
: #if ( -- node ) peek-d 1array \ #if in-node ;
|
||||
|
||||
TUPLE: #dispatch ;
|
||||
TUPLE: #dispatch < #branch ;
|
||||
|
||||
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
|
||||
|
||||
TUPLE: #merge ;
|
||||
TUPLE: #merge < node ;
|
||||
|
||||
: #merge ( -- node ) \ #merge all-out-node ;
|
||||
|
||||
TUPLE: #terminate ;
|
||||
TUPLE: #terminate < node ;
|
||||
|
||||
: #terminate ( -- node ) \ #terminate empty-node ;
|
||||
: #terminate ( -- node ) \ #terminate construct-empty ;
|
||||
|
||||
TUPLE: #declare ;
|
||||
TUPLE: #declare < node ;
|
||||
|
||||
: #declare ( classes -- node ) \ #declare param-node ;
|
||||
|
||||
UNION: #branch #if #dispatch ;
|
||||
|
||||
: node-inputs ( d-count r-count node -- )
|
||||
tuck
|
||||
>r r-tail flatten-curries r> set-node-in-r
|
||||
>r d-tail flatten-curries r> set-node-in-d ;
|
||||
[ swap d-tail flatten-curries >>in-d drop ]
|
||||
[ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
|
||||
|
||||
: node-outputs ( d-count r-count node -- )
|
||||
tuck
|
||||
>r r-tail flatten-curries r> set-node-out-r
|
||||
>r d-tail flatten-curries r> set-node-out-d ;
|
||||
[ swap d-tail flatten-curries >>out-d drop ]
|
||||
[ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
|
||||
|
||||
: node, ( node -- )
|
||||
dataflow-graph get [
|
||||
|
|
@ -178,17 +174,15 @@ UNION: #branch #if #dispatch ;
|
|||
] if ;
|
||||
|
||||
: node-values ( node -- values )
|
||||
dup node-in-d
|
||||
over node-out-d
|
||||
pick node-in-r
|
||||
roll node-out-r 4array concat ;
|
||||
{ [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
|
||||
4array concat ;
|
||||
|
||||
: last-node ( node -- last )
|
||||
dup node-successor [ last-node ] [ ] ?if ;
|
||||
dup successor>> [ last-node ] [ ] ?if ;
|
||||
|
||||
: penultimate-node ( node -- penultimate )
|
||||
dup node-successor dup [
|
||||
dup node-successor
|
||||
dup successor>> dup [
|
||||
dup successor>>
|
||||
[ nip penultimate-node ] [ drop ] if
|
||||
] [
|
||||
2drop f
|
||||
|
|
@ -202,7 +196,7 @@ UNION: #branch #if #dispatch ;
|
|||
2dup 2slip rot [
|
||||
2drop t
|
||||
] [
|
||||
>r dup node-children swap node-successor suffix r>
|
||||
>r [ children>> ] [ successor>> ] bi suffix r>
|
||||
[ node-exists? ] curry contains?
|
||||
] if
|
||||
] [
|
||||
|
|
@ -213,13 +207,13 @@ GENERIC: calls-label* ( label node -- ? )
|
|||
|
||||
M: node calls-label* 2drop f ;
|
||||
|
||||
M: #call-label calls-label* node-param eq? ;
|
||||
M: #call-label calls-label* param>> eq? ;
|
||||
|
||||
: calls-label? ( label node -- ? )
|
||||
[ calls-label* ] with node-exists? ;
|
||||
|
||||
: recursive-label? ( node -- ? )
|
||||
dup node-param swap calls-label? ;
|
||||
[ param>> ] keep calls-label? ;
|
||||
|
||||
SYMBOL: node-stack
|
||||
|
||||
|
|
@ -227,7 +221,7 @@ SYMBOL: node-stack
|
|||
: node> node-stack get pop ;
|
||||
: node@ node-stack get peek ;
|
||||
|
||||
: iterate-next ( -- node ) node@ node-successor ;
|
||||
: iterate-next ( -- node ) node@ successor>> ;
|
||||
|
||||
: iterate-nodes ( node quot -- )
|
||||
over [
|
||||
|
|
@ -255,54 +249,55 @@ SYMBOL: node-stack
|
|||
] iterate-nodes drop
|
||||
] with-node-iterator ; inline
|
||||
|
||||
: change-children ( node quot -- )
|
||||
: map-children ( node quot -- )
|
||||
over [
|
||||
>r dup node-children dup r>
|
||||
[ map swap set-node-children ] curry
|
||||
[ 2drop ] if
|
||||
over children>> [
|
||||
[ map ] curry change-children drop
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] [
|
||||
2drop
|
||||
] if ; inline
|
||||
|
||||
: (transform-nodes) ( prev node quot -- )
|
||||
dup >r call dup [
|
||||
dup rot set-node-successor
|
||||
dup node-successor r> (transform-nodes)
|
||||
>>successor
|
||||
successor>> dup successor>>
|
||||
r> (transform-nodes)
|
||||
] [
|
||||
r> drop f swap set-node-successor drop
|
||||
r> 2drop f >>successor drop
|
||||
] if ; inline
|
||||
|
||||
: transform-nodes ( node quot -- new-node )
|
||||
over [
|
||||
[ call dup dup node-successor ] keep (transform-nodes)
|
||||
[ call dup dup successor>> ] keep (transform-nodes)
|
||||
] [ drop ] if ; inline
|
||||
|
||||
: node-literal? ( node value -- ? )
|
||||
dup value? >r swap node-literals key? r> or ;
|
||||
dup value? >r swap literals>> key? r> or ;
|
||||
|
||||
: node-literal ( node value -- obj )
|
||||
dup value?
|
||||
[ nip value-literal ] [ swap node-literals at ] if ;
|
||||
[ nip value-literal ] [ swap literals>> at ] if ;
|
||||
|
||||
: node-interval ( node value -- interval )
|
||||
swap node-intervals at ;
|
||||
swap intervals>> at ;
|
||||
|
||||
: node-class ( node value -- class )
|
||||
swap node-classes at object or ;
|
||||
swap classes>> at object or ;
|
||||
|
||||
: node-input-classes ( node -- seq )
|
||||
dup node-in-d [ node-class ] with map ;
|
||||
dup in-d>> [ node-class ] with map ;
|
||||
|
||||
: node-input-intervals ( node -- seq )
|
||||
dup node-in-d [ node-interval ] with map ;
|
||||
dup in-d>> [ node-interval ] with map ;
|
||||
|
||||
: node-class-first ( node -- class )
|
||||
dup node-in-d first node-class ;
|
||||
dup in-d>> first node-class ;
|
||||
|
||||
: active-children ( node -- seq )
|
||||
node-children
|
||||
[ last-node ] map
|
||||
[ #terminate? not ] subset ;
|
||||
children>> [ last-node ] map [ #terminate? not ] subset ;
|
||||
|
||||
DEFER: #tail?
|
||||
|
||||
|
|
@ -317,5 +312,5 @@ UNION: #tail
|
|||
#! We don't consider calls which do non-local exits to be
|
||||
#! tail calls, because this gives better error traces.
|
||||
node-stack get [
|
||||
node-successor dup #tail? swap #terminate? not and
|
||||
successor>> [ #tail? ] [ #terminate? not ] bi and
|
||||
] all? ;
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: inference.errors
|
||||
USING: inference.backend inference.dataflow kernel generic
|
||||
sequences prettyprint io words arrays inspector effects debugger
|
||||
assocs ;
|
||||
assocs accessors ;
|
||||
|
||||
M: inference-error error.
|
||||
dup inference-error-rstate
|
||||
dup rstate>>
|
||||
keys [ dup value? [ value-literal ] when ] map
|
||||
dup empty? [ "Word: " write dup peek . ] unless
|
||||
swap delegate error. "Nesting: " write . ;
|
||||
swap error>> error. "Nesting: " write . ;
|
||||
|
||||
M: inference-error error-help drop f ;
|
||||
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@ HELP: inference-error
|
|||
{ $error-description
|
||||
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
|
||||
$nl
|
||||
"This error always delegates to one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
|
||||
"The " { $snippet "error" } " slot contains one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
|
||||
{ $list
|
||||
{ $link no-effect }
|
||||
{ $link literal-expected }
|
||||
|
|
|
|||
|
|
@ -8,6 +8,9 @@ classes.predicate debugger threads.private io.streams.string
|
|||
io.timeouts io.thread sequences.private ;
|
||||
IN: inference.tests
|
||||
|
||||
[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
|
||||
[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
|
||||
|
||||
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
||||
{ 1 2 } [ dup ] must-infer-as
|
||||
|
||||
|
|
@ -542,3 +545,5 @@ ERROR: custom-error ;
|
|||
: missing->r-check >r ;
|
||||
|
||||
[ [ missing->r-check ] infer ] must-fail
|
||||
|
||||
{ 1 0 } [ [ ] map-children ] must-infer-as
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ ABOUT: "io.streams.string"
|
|||
|
||||
HELP: <string-writer>
|
||||
{ $values { "stream" "an output stream" } }
|
||||
{ $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ;
|
||||
{ $description "Creates an output stream that collects text into a string buffer. The contents of the buffer can be obtained by executing " { $link >string } "." } ;
|
||||
|
||||
HELP: with-string-writer
|
||||
{ $values { "quot" quotation } { "str" string } }
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays hashtables io kernel math math.parser memory
|
||||
namespaces parser sequences strings io.styles
|
||||
io.streams.duplex vectors words generic system combinators
|
||||
continuations debugger definitions compiler.units ;
|
||||
continuations debugger definitions compiler.units accessors ;
|
||||
IN: listener
|
||||
|
||||
SYMBOL: quit-flag
|
||||
|
|
@ -19,7 +19,7 @@ GENERIC: stream-read-quot ( stream -- quot/f )
|
|||
|
||||
: read-quot-step ( lines -- quot/f )
|
||||
[ parse-lines-interactive ] [
|
||||
dup delegate unexpected-eof?
|
||||
dup error>> unexpected-eof?
|
||||
[ 2drop f ] [ rethrow ] if
|
||||
] recover ;
|
||||
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
|
|||
DEFER: optimize-nodes
|
||||
|
||||
: optimize-children ( node -- )
|
||||
[ optimize-nodes ] change-children ;
|
||||
[ optimize-nodes ] map-children ;
|
||||
|
||||
: optimize-node ( node -- node )
|
||||
dup [
|
||||
|
|
|
|||
|
|
@ -100,7 +100,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
|
|||
dup [
|
||||
dup [ dead-literals get swap remove-all ] modify-values
|
||||
dup kill-node* dup t eq? [
|
||||
drop dup [ kill-nodes ] change-children
|
||||
drop dup [ kill-nodes ] map-children
|
||||
] [
|
||||
nip kill-node
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -157,23 +157,33 @@ name>char-hook global [
|
|||
[ swap tail-slice (parse-string) ] "" make swap
|
||||
] change-lexer-column ;
|
||||
|
||||
TUPLE: parse-error file line col text ;
|
||||
TUPLE: parse-error file line column line-text error ;
|
||||
|
||||
: <parse-error> ( msg -- error )
|
||||
file get
|
||||
lexer get [ line>> ] [ column>> ] [ line-text>> ] tri
|
||||
parse-error construct-boa
|
||||
[ set-delegate ] keep ;
|
||||
\ parse-error construct-empty
|
||||
file get >>file
|
||||
lexer get line>> >>line
|
||||
lexer get column>> >>column
|
||||
lexer get line-text>> >>line-text
|
||||
swap >>error ;
|
||||
|
||||
: parse-dump ( error -- )
|
||||
dup parse-error-file file.
|
||||
dup parse-error-line number>string print
|
||||
dup parse-error-text dup string? [ print ] [ drop ] if
|
||||
parse-error-col 0 or CHAR: \s <string> write
|
||||
{
|
||||
[ file>> file. ]
|
||||
[ line>> number>string print ]
|
||||
[ line-text>> dup string? [ print ] [ drop ] if ]
|
||||
[ column>> 0 or CHAR: \s <string> write ]
|
||||
} cleave
|
||||
"^" print ;
|
||||
|
||||
M: parse-error error.
|
||||
dup parse-dump delegate error. ;
|
||||
[ parse-dump ] [ error>> error. ] bi ;
|
||||
|
||||
M: parse-error summary
|
||||
error>> summary ;
|
||||
|
||||
M: parse-error compute-restarts
|
||||
error>> compute-restarts ;
|
||||
|
||||
SYMBOL: use
|
||||
SYMBOL: in
|
||||
|
|
@ -409,6 +419,7 @@ SYMBOL: bootstrap-syntax
|
|||
SYMBOL: interactive-vocabs
|
||||
|
||||
{
|
||||
"accessors"
|
||||
"arrays"
|
||||
"assocs"
|
||||
"combinators"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,22 @@
|
|||
USING: refs tools.test kernel ;
|
||||
|
||||
[ 3 ] [
|
||||
H{ { "a" 3 } } "a" <value-ref> get-ref
|
||||
] unit-test
|
||||
|
||||
[ 4 ] [
|
||||
4 H{ { "a" 3 } } clone "a" <value-ref>
|
||||
[ set-ref ] keep
|
||||
get-ref
|
||||
] unit-test
|
||||
|
||||
[ "a" ] [
|
||||
H{ { "a" 3 } } "a" <key-ref> get-ref
|
||||
] unit-test
|
||||
|
||||
[ H{ { "b" 3 } } ] [
|
||||
"b" H{ { "a" 3 } } clone [
|
||||
"a" <key-ref>
|
||||
set-ref
|
||||
] keep
|
||||
] unit-test
|
||||
|
|
@ -5,21 +5,18 @@ IN: refs
|
|||
|
||||
TUPLE: ref assoc key ;
|
||||
|
||||
: <ref> ( assoc key class -- tuple )
|
||||
>r ref construct-boa r> construct-delegate ; inline
|
||||
|
||||
: >ref< ( ref -- key assoc ) [ key>> ] [ assoc>> ] bi ;
|
||||
: >ref< [ key>> ] [ assoc>> ] bi ; inline
|
||||
|
||||
: delete-ref ( ref -- ) >ref< delete-at ;
|
||||
GENERIC: get-ref ( ref -- obj )
|
||||
GENERIC: set-ref ( obj ref -- )
|
||||
|
||||
TUPLE: key-ref ;
|
||||
: <key-ref> ( assoc key -- ref ) key-ref <ref> ;
|
||||
M: key-ref get-ref ref-key ;
|
||||
TUPLE: key-ref < ref ;
|
||||
C: <key-ref> key-ref ( assoc key -- ref )
|
||||
M: key-ref get-ref key>> ;
|
||||
M: key-ref set-ref >ref< rename-at ;
|
||||
|
||||
TUPLE: value-ref ;
|
||||
: <value-ref> ( assoc key -- ref ) value-ref <ref> ;
|
||||
TUPLE: value-ref < ref ;
|
||||
C: <value-ref> value-ref ( assoc key -- ref )
|
||||
M: value-ref get-ref >ref< at ;
|
||||
M: value-ref set-ref >ref< set-at ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces
|
|||
prettyprint sequences strings vectors words quotations inspector
|
||||
io.styles io combinators sorting splitting math.parser effects
|
||||
continuations debugger io.files io.crc32 vocabs hashtables
|
||||
graphs compiler.units io.encodings.utf8 ;
|
||||
graphs compiler.units io.encodings.utf8 accessors ;
|
||||
IN: source-files
|
||||
|
||||
SYMBOL: source-files
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ M: link uses
|
|||
collect-elements [ \ f or ] map ;
|
||||
|
||||
: help-path ( topic -- seq )
|
||||
[ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ;
|
||||
[ article-parent ] follow 1 tail ;
|
||||
|
||||
: set-article-parents ( parent article -- )
|
||||
article-children [ set-article-parent ] with each ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@ math.vectors models namespaces parser prettyprint quotations
|
|||
sequences sequences.lib strings threads listener
|
||||
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
||||
definitions boxes calendar concurrency.flags ui.tools.workspace ;
|
||||
definitions boxes calendar concurrency.flags ui.tools.workspace
|
||||
accessors ;
|
||||
IN: ui.tools.interactor
|
||||
|
||||
TUPLE: interactor history output flag thread help ;
|
||||
|
|
@ -123,12 +124,12 @@ M: interactor stream-read-partial
|
|||
stream-read ;
|
||||
|
||||
: go-to-error ( interactor error -- )
|
||||
dup parse-error-line 1- swap parse-error-col 2array
|
||||
[ line>> 1- ] [ column>> ] bi 2array
|
||||
over set-caret
|
||||
mark>caret ;
|
||||
|
||||
: handle-parse-error ( interactor error -- )
|
||||
dup parse-error? [ 2dup go-to-error delegate ] when
|
||||
dup parse-error? [ 2dup go-to-error error>> ] when
|
||||
swap find-workspace debugger-popup ;
|
||||
|
||||
: try-parse ( lines interactor -- quot/error/f )
|
||||
|
|
|
|||
Loading…
Reference in New Issue