core: callstack is a builtin type and a class name. rename the *stack words that grab the current stack get-foostack to avoid the callstack builtin conflict and for better symmetry with set-foostack.
parent
0e1169ceab
commit
c21a154056
|
@ -66,7 +66,7 @@ IN: compiler.tests.simple
|
||||||
|
|
||||||
! Regression
|
! Regression
|
||||||
|
|
||||||
[ ] [ [ callstack ] compile-call drop ] unit-test
|
[ ] [ [ get-callstack ] compile-call drop ] unit-test
|
||||||
|
|
||||||
! Regression
|
! Regression
|
||||||
|
|
||||||
|
|
|
@ -55,7 +55,7 @@ M: tuple error. describe ;
|
||||||
'[ dup _ assoc-stack ] H{ } map>assoc ;
|
'[ dup _ assoc-stack ] H{ } map>assoc ;
|
||||||
|
|
||||||
: .vars ( -- )
|
: .vars ( -- )
|
||||||
namestack vars-in-scope describe ;
|
get-namestack vars-in-scope describe ;
|
||||||
|
|
||||||
: :vars ( -- )
|
: :vars ( -- )
|
||||||
error-continuation get name>> vars-in-scope describe ;
|
error-continuation get name>> vars-in-scope describe ;
|
||||||
|
|
|
@ -49,8 +49,8 @@ IN: prettyprint
|
||||||
] recover
|
] recover
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
: .s ( -- ) datastack stack. ;
|
: .s ( -- ) get-datastack stack. ;
|
||||||
: .r ( -- ) retainstack stack. ;
|
: .r ( -- ) get-retainstack stack. ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
@ -125,7 +125,7 @@ PRIVATE>
|
||||||
callstack>array 3 <groups>
|
callstack>array 3 <groups>
|
||||||
{ { table-gap { 5 5 } } } [ [ callframe. ] each ] tabular-output nl ;
|
{ { table-gap { 5 5 } } } [ [ callframe. ] each ] tabular-output nl ;
|
||||||
|
|
||||||
: .c ( -- ) callstack callstack. ;
|
: .c ( -- ) get-callstack callstack. ;
|
||||||
|
|
||||||
: pprint-cell ( obj -- ) [ pprint-short ] with-cell ;
|
: pprint-cell ( obj -- ) [ pprint-short ] with-cell ;
|
||||||
|
|
||||||
|
|
|
@ -346,7 +346,7 @@ M: object infer-call* \ call bad-macro-input ;
|
||||||
\ bits>double { integer } { float } define-primitive \ bits>double make-foldable
|
\ bits>double { integer } { float } define-primitive \ bits>double make-foldable
|
||||||
\ bits>float { integer } { float } define-primitive \ bits>float make-foldable
|
\ bits>float { integer } { float } define-primitive \ bits>float make-foldable
|
||||||
\ both-fixnums? { object object } { object } define-primitive
|
\ both-fixnums? { object object } { object } define-primitive
|
||||||
\ callstack { } { callstack } define-primitive \ callstack make-flushable
|
\ get-callstack { } { callstack } define-primitive \ get-callstack make-flushable
|
||||||
\ callstack-bounds { } { alien alien } define-primitive \ callstack-bounds make-flushable
|
\ callstack-bounds { } { alien alien } define-primitive \ callstack-bounds make-flushable
|
||||||
\ callstack-for { c-ptr } { callstack } define-primitive \ callstack make-flushable
|
\ callstack-for { c-ptr } { callstack } define-primitive \ callstack make-flushable
|
||||||
\ callstack>array { callstack } { array } define-primitive \ callstack>array make-flushable
|
\ callstack>array { callstack } { array } define-primitive \ callstack>array make-flushable
|
||||||
|
@ -359,7 +359,7 @@ M: object infer-call* \ call bad-macro-input ;
|
||||||
\ current-callback { } { fixnum } define-primitive \ current-callback make-flushable
|
\ current-callback { } { fixnum } define-primitive \ current-callback make-flushable
|
||||||
\ (callback-room) { } { byte-array } define-primitive \ (callback-room) make-flushable
|
\ (callback-room) { } { byte-array } define-primitive \ (callback-room) make-flushable
|
||||||
\ (data-room) { } { byte-array } define-primitive \ (data-room) make-flushable
|
\ (data-room) { } { byte-array } define-primitive \ (data-room) make-flushable
|
||||||
\ datastack { } { array } define-primitive \ datastack make-flushable
|
\ get-datastack { } { array } define-primitive \ get-datastack make-flushable
|
||||||
\ datastack-for { c-ptr } { array } define-primitive \ datastack-for make-flushable
|
\ datastack-for { c-ptr } { array } define-primitive \ datastack-for make-flushable
|
||||||
\ die { } { } define-primitive
|
\ die { } { } define-primitive
|
||||||
\ disable-gc-events { } { object } define-primitive
|
\ disable-gc-events { } { object } define-primitive
|
||||||
|
@ -438,7 +438,7 @@ M: object infer-call* \ call bad-macro-input ;
|
||||||
\ resize-array { integer array } { array } define-primitive
|
\ resize-array { integer array } { array } define-primitive
|
||||||
\ resize-byte-array { integer byte-array } { byte-array } define-primitive
|
\ resize-byte-array { integer byte-array } { byte-array } define-primitive
|
||||||
\ resize-string { integer string } { string } define-primitive
|
\ resize-string { integer string } { string } define-primitive
|
||||||
\ retainstack { } { array } define-primitive \ retainstack make-flushable
|
\ get-retainstack { } { array } define-primitive \ get-retainstack make-flushable
|
||||||
\ retainstack-for { c-ptr } { array } define-primitive \ retainstack-for make-flushable
|
\ retainstack-for { c-ptr } { array } define-primitive \ retainstack-for make-flushable
|
||||||
\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
|
\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
|
||||||
\ set-alien-double { float c-ptr integer } { } define-primitive
|
\ set-alien-double { float c-ptr integer } { } define-primitive
|
||||||
|
|
|
@ -228,7 +228,7 @@ M: real sleep
|
||||||
>integer nano-count + sleep-until ;
|
>integer nano-count + sleep-until ;
|
||||||
|
|
||||||
: (spawn) ( thread -- )
|
: (spawn) ( thread -- )
|
||||||
[ register-thread ] [ [ namestack ] dip resume-with ] bi ;
|
[ register-thread ] [ [ get-namestack ] dip resume-with ] bi ;
|
||||||
|
|
||||||
: spawn ( quot name -- thread )
|
: spawn ( quot name -- thread )
|
||||||
<thread> [ (spawn) ] keep ;
|
<thread> [ (spawn) ] keep ;
|
||||||
|
@ -237,7 +237,7 @@ M: real sleep
|
||||||
[ '[ _ loop ] ] dip spawn ;
|
[ '[ _ loop ] ] dip spawn ;
|
||||||
|
|
||||||
: in-thread ( quot -- )
|
: in-thread ( quot -- )
|
||||||
[ datastack ] dip
|
[ get-datastack ] dip
|
||||||
'[ _ set-datastack @ ]
|
'[ _ set-datastack @ ]
|
||||||
"Thread" spawn drop ;
|
"Thread" spawn drop ;
|
||||||
|
|
||||||
|
|
|
@ -21,7 +21,7 @@ PRIVATE>
|
||||||
SYMBOL: break-hook
|
SYMBOL: break-hook
|
||||||
|
|
||||||
: break ( -- )
|
: break ( -- )
|
||||||
current-continuation callstack >>call
|
current-continuation get-callstack >>call
|
||||||
break-hook get call( continuation -- continuation' )
|
break-hook get call( continuation -- continuation' )
|
||||||
after-break ;
|
after-break ;
|
||||||
|
|
||||||
|
@ -63,7 +63,7 @@ M: object add-breakpoint ;
|
||||||
\ (step-into-execute) t "step-into?" set-word-prop
|
\ (step-into-execute) t "step-into?" set-word-prop
|
||||||
|
|
||||||
: (step-into-continuation) ( -- )
|
: (step-into-continuation) ( -- )
|
||||||
current-continuation callstack >>call break ;
|
current-continuation get-callstack >>call break ;
|
||||||
|
|
||||||
: (step-into-call-next-method) ( method -- )
|
: (step-into-call-next-method) ( method -- )
|
||||||
next-method-quot (step-into-quotation) ;
|
next-method-quot (step-into-quotation) ;
|
||||||
|
|
|
@ -451,11 +451,11 @@ tuple
|
||||||
{ "fwrite" "io.streams.c" "primitive_fwrite" ( data length alien -- ) }
|
{ "fwrite" "io.streams.c" "primitive_fwrite" ( data length alien -- ) }
|
||||||
{ "(clone)" "kernel" "primitive_clone" ( obj -- newobj ) }
|
{ "(clone)" "kernel" "primitive_clone" ( obj -- newobj ) }
|
||||||
{ "<wrapper>" "kernel" "primitive_wrapper" ( obj -- wrapper ) }
|
{ "<wrapper>" "kernel" "primitive_wrapper" ( obj -- wrapper ) }
|
||||||
{ "callstack" "kernel" "primitive_callstack" ( -- callstack ) }
|
{ "get-callstack" "kernel" "primitive_callstack" ( -- callstack ) }
|
||||||
{ "callstack>array" "kernel" "primitive_callstack_to_array" ( callstack -- array ) }
|
{ "callstack>array" "kernel" "primitive_callstack_to_array" ( callstack -- array ) }
|
||||||
{ "datastack" "kernel" "primitive_datastack" ( -- array ) }
|
{ "get-datastack" "kernel" "primitive_datastack" ( -- array ) }
|
||||||
{ "die" "kernel" "primitive_die" ( -- ) }
|
{ "die" "kernel" "primitive_die" ( -- ) }
|
||||||
{ "retainstack" "kernel" "primitive_retainstack" ( -- array ) }
|
{ "get-retainstack" "kernel" "primitive_retainstack" ( -- array ) }
|
||||||
{ "(identity-hashcode)" "kernel.private" "primitive_identity_hashcode" ( obj -- code ) }
|
{ "(identity-hashcode)" "kernel.private" "primitive_identity_hashcode" ( obj -- code ) }
|
||||||
{ "become" "kernel.private" "primitive_become" ( old new -- ) }
|
{ "become" "kernel.private" "primitive_become" ( old new -- ) }
|
||||||
{ "callstack-bounds" "kernel.private" "primitive_callstack_bounds" ( -- start end ) }
|
{ "callstack-bounds" "kernel.private" "primitive_callstack_bounds" ( -- start end ) }
|
||||||
|
|
|
@ -6,7 +6,7 @@ IN: combinators.tests
|
||||||
{ 3 } [ 1 2 [ + ] call( x y -- z ) ] unit-test
|
{ 3 } [ 1 2 [ + ] call( x y -- z ) ] unit-test
|
||||||
[ 1 2 [ + ] call( -- z ) ] must-fail
|
[ 1 2 [ + ] call( -- z ) ] must-fail
|
||||||
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
|
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
|
||||||
{ 1 2 3 { 1 2 3 4 } } [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
|
{ 1 2 3 { 1 2 3 4 } } [ 1 2 3 4 [ get-datastack nip ] call( x -- y ) ] unit-test
|
||||||
[ [ + ] call( x y -- z ) ] must-infer
|
[ [ + ] call( x y -- z ) ] must-infer
|
||||||
|
|
||||||
{ 3 } [ 1 2 \ + execute( x y -- z ) ] unit-test
|
{ 3 } [ 1 2 \ + execute( x y -- z ) ] unit-test
|
||||||
|
|
|
@ -32,7 +32,7 @@ SLOT: terminated?
|
||||||
! Don't use fancy combinators here, since this word always
|
! Don't use fancy combinators here, since this word always
|
||||||
! runs unoptimized
|
! runs unoptimized
|
||||||
2dup [
|
2dup [
|
||||||
[ [ datastack ] dip dip ] dip
|
[ [ get-datastack ] dip dip ] dip
|
||||||
dup terminated?>> [ 2drop f ] [
|
dup terminated?>> [ 2drop f ] [
|
||||||
dup in>> length swap out>> length
|
dup in>> length swap out>> length
|
||||||
check-datastack
|
check-datastack
|
||||||
|
|
|
@ -71,15 +71,15 @@ ARTICLE: "continuations.private" "Continuation implementation details"
|
||||||
}
|
}
|
||||||
"The five stacks can be read and written:"
|
"The five stacks can be read and written:"
|
||||||
{ $subsections
|
{ $subsections
|
||||||
datastack
|
get-datastack
|
||||||
set-datastack
|
set-datastack
|
||||||
retainstack
|
get-retainstack
|
||||||
set-retainstack
|
set-retainstack
|
||||||
callstack
|
get-callstack
|
||||||
set-callstack
|
set-callstack
|
||||||
namestack
|
get-namestack
|
||||||
set-namestack
|
set-namestack
|
||||||
catchstack
|
get-catchstack
|
||||||
set-catchstack
|
set-catchstack
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
@ -112,7 +112,7 @@ HELP: catchstack*
|
||||||
{ $values { "catchstack" "a vector of continuations" } }
|
{ $values { "catchstack" "a vector of continuations" } }
|
||||||
{ $description "Outputs the current catchstack." } ;
|
{ $description "Outputs the current catchstack." } ;
|
||||||
|
|
||||||
HELP: catchstack
|
HELP: get-catchstack
|
||||||
{ $values { "catchstack" "a vector of continuations" } }
|
{ $values { "catchstack" "a vector of continuations" } }
|
||||||
{ $description "Outputs a copy of the current catchstack." } ;
|
{ $description "Outputs a copy of the current catchstack." } ;
|
||||||
|
|
||||||
|
|
|
@ -75,7 +75,7 @@ os windows? [
|
||||||
] unless
|
] unless
|
||||||
|
|
||||||
: don't-compile-me ( -- ) ;
|
: don't-compile-me ( -- ) ;
|
||||||
: foo ( -- ) callstack "c" set don't-compile-me ;
|
: foo ( -- ) get-callstack "c" set don't-compile-me ;
|
||||||
: bar ( -- a b ) 1 foo 2 ;
|
: bar ( -- a b ) 1 foo 2 ;
|
||||||
|
|
||||||
<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
|
<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
|
||||||
|
|
|
@ -6,8 +6,8 @@ IN: continuations
|
||||||
|
|
||||||
: with-datastack ( stack quot -- new-stack )
|
: with-datastack ( stack quot -- new-stack )
|
||||||
[
|
[
|
||||||
[ [ datastack ] dip swap [ { } like set-datastack ] dip ] dip
|
[ [ get-datastack ] dip swap [ { } like set-datastack ] dip ] dip
|
||||||
swap [ call datastack ] dip
|
swap [ call get-datastack ] dip
|
||||||
swap [ set-datastack ] dip
|
swap [ set-datastack ] dip
|
||||||
] ( stack quot -- new-stack ) call-effect-unsafe ;
|
] ( stack quot -- new-stack ) call-effect-unsafe ;
|
||||||
|
|
||||||
|
@ -26,7 +26,7 @@ SYMBOL: restarts
|
||||||
: dummy-1 ( -- obj ) f ;
|
: dummy-1 ( -- obj ) f ;
|
||||||
: dummy-2 ( obj -- obj ) ;
|
: dummy-2 ( obj -- obj ) ;
|
||||||
|
|
||||||
: catchstack ( -- catchstack ) catchstack* clone ; inline
|
: get-catchstack ( -- catchstack ) catchstack* clone ; inline
|
||||||
|
|
||||||
: (set-catchstack) ( catchstack -- )
|
: (set-catchstack) ( catchstack -- )
|
||||||
CONTEXT-OBJ-CATCHSTACK set-context-object ; inline
|
CONTEXT-OBJ-CATCHSTACK set-context-object ; inline
|
||||||
|
@ -44,7 +44,7 @@ TUPLE: continuation data call retain name catch ;
|
||||||
C: <continuation> continuation
|
C: <continuation> continuation
|
||||||
|
|
||||||
: current-continuation ( -- continuation )
|
: current-continuation ( -- continuation )
|
||||||
datastack callstack retainstack namestack catchstack
|
get-datastack get-callstack get-retainstack get-namestack get-catchstack
|
||||||
<continuation> ;
|
<continuation> ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
|
@ -43,7 +43,7 @@ M: standard-combination picker
|
||||||
M: standard-combination dispatch# #>> ;
|
M: standard-combination dispatch# #>> ;
|
||||||
|
|
||||||
M: standard-generic effective-method
|
M: standard-generic effective-method
|
||||||
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
|
[ get-datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
|
||||||
method-for-object ;
|
method-for-object ;
|
||||||
|
|
||||||
: inline-cache-quot ( word methods miss-word -- quot )
|
: inline-cache-quot ( word methods miss-word -- quot )
|
||||||
|
|
|
@ -26,7 +26,7 @@ HELP: -rot $complex-shuffle ;
|
||||||
HELP: dupd $complex-shuffle ;
|
HELP: dupd $complex-shuffle ;
|
||||||
HELP: swapd $complex-shuffle ;
|
HELP: swapd $complex-shuffle ;
|
||||||
|
|
||||||
HELP: datastack
|
HELP: get-datastack
|
||||||
{ $values { "array" array } }
|
{ $values { "array" array } }
|
||||||
{ $description "Outputs an array containing a copy of the data stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
|
{ $description "Outputs an array containing a copy of the data stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
|
||||||
|
|
||||||
|
@ -34,7 +34,7 @@ HELP: set-datastack
|
||||||
{ $values { "array" array } }
|
{ $values { "array" array } }
|
||||||
{ $description "Replaces the data stack contents with a copy of an array. The end of the array becomes the top of the stack." } ;
|
{ $description "Replaces the data stack contents with a copy of an array. The end of the array becomes the top of the stack." } ;
|
||||||
|
|
||||||
HELP: retainstack
|
HELP: get-retainstack
|
||||||
{ $values { "array" array } }
|
{ $values { "array" array } }
|
||||||
{ $description "Outputs an array containing a copy of the retain stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
|
{ $description "Outputs an array containing a copy of the retain stack contents right before the call to this word, with the top of the stack at the end of the array." } ;
|
||||||
|
|
||||||
|
@ -42,7 +42,7 @@ HELP: set-retainstack
|
||||||
{ $values { "array" array } }
|
{ $values { "array" array } }
|
||||||
{ $description "Replaces the retain stack contents with a copy of an array. The end of the array becomes the top of the stack." } ;
|
{ $description "Replaces the retain stack contents with a copy of an array. The end of the array becomes the top of the stack." } ;
|
||||||
|
|
||||||
HELP: callstack
|
HELP: get-callstack
|
||||||
{ $values { "callstack" callstack } }
|
{ $values { "callstack" callstack } }
|
||||||
{ $description "Outputs a copy of the call stack contents, with the top of the stack at the end of the vector. The stack frame of the caller word is " { $emphasis "not" } " included. Each group of three elements in the callstack is frame:"
|
{ $description "Outputs a copy of the call stack contents, with the top of the stack at the end of the vector. The stack frame of the caller word is " { $emphasis "not" } " included. Each group of three elements in the callstack is frame:"
|
||||||
{ $list
|
{ $list
|
||||||
|
|
|
@ -129,9 +129,9 @@ os windows? [
|
||||||
|
|
||||||
{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
|
{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
|
||||||
|
|
||||||
{ } [ callstack set-callstack ] unit-test
|
{ } [ get-callstack set-callstack ] unit-test
|
||||||
|
|
||||||
[ 3drop datastack ] must-fail
|
[ 3drop get-datastack ] must-fail
|
||||||
{ } [ :c ] unit-test
|
{ } [ :c ] unit-test
|
||||||
|
|
||||||
! Doesn't compile; important
|
! Doesn't compile; important
|
||||||
|
|
|
@ -28,9 +28,9 @@ PRIMITIVE: 4dup ( w x y z -- w x y z w x y z )
|
||||||
PRIMITIVE: (clone) ( obj -- newobj )
|
PRIMITIVE: (clone) ( obj -- newobj )
|
||||||
PRIMITIVE: eq? ( obj1 obj2 -- ? )
|
PRIMITIVE: eq? ( obj1 obj2 -- ? )
|
||||||
PRIMITIVE: <wrapper> ( obj -- wrapper )
|
PRIMITIVE: <wrapper> ( obj -- wrapper )
|
||||||
PRIMITIVE: callstack ( -- callstack )
|
PRIMITIVE: get-datastack ( -- array )
|
||||||
PRIMITIVE: datastack ( -- array )
|
PRIMITIVE: get-callstack ( -- callstack )
|
||||||
PRIMITIVE: retainstack ( -- array )
|
PRIMITIVE: get-retainstack ( -- array )
|
||||||
PRIMITIVE: die ( -- )
|
PRIMITIVE: die ( -- )
|
||||||
PRIMITIVE: callstack>array ( callstack -- array )
|
PRIMITIVE: callstack>array ( callstack -- array )
|
||||||
|
|
||||||
|
|
|
@ -33,7 +33,7 @@ ARTICLE: "namespaces-global" "Global variables"
|
||||||
ARTICLE: "namespaces.private" "Namespace implementation details"
|
ARTICLE: "namespaces.private" "Namespace implementation details"
|
||||||
"The namestack holds namespaces."
|
"The namestack holds namespaces."
|
||||||
{ $subsections
|
{ $subsections
|
||||||
namestack
|
get-namestack
|
||||||
set-namestack
|
set-namestack
|
||||||
namespace
|
namespace
|
||||||
}
|
}
|
||||||
|
@ -169,7 +169,7 @@ HELP: namestack*
|
||||||
{ $values { "namestack" "a vector of assocs" } }
|
{ $values { "namestack" "a vector of assocs" } }
|
||||||
{ $description "Outputs the current name stack." } ;
|
{ $description "Outputs the current name stack." } ;
|
||||||
|
|
||||||
HELP: namestack
|
HELP: get-namestack
|
||||||
{ $values { "namestack" "a vector of assocs" } }
|
{ $values { "namestack" "a vector of assocs" } }
|
||||||
{ $description "Outputs a copy of the current name stack." } ;
|
{ $description "Outputs a copy of the current name stack." } ;
|
||||||
|
|
||||||
|
|
|
@ -41,7 +41,7 @@ PRIVATE>
|
||||||
: global ( -- g ) OBJ-GLOBAL special-object { global-hashtable } declare ; foldable
|
: global ( -- g ) OBJ-GLOBAL special-object { global-hashtable } declare ; foldable
|
||||||
|
|
||||||
: namespace ( -- namespace ) namestack* last ; inline
|
: namespace ( -- namespace ) namestack* last ; inline
|
||||||
: namestack ( -- namestack ) namestack* clone ;
|
: get-namestack ( -- namestack ) namestack* clone ;
|
||||||
: set-namestack ( namestack -- )
|
: set-namestack ( namestack -- )
|
||||||
>vector CONTEXT-OBJ-NAMESTACK set-context-object ;
|
>vector CONTEXT-OBJ-NAMESTACK set-context-object ;
|
||||||
: init-namespaces ( -- ) global 1array set-namestack ;
|
: init-namespaces ( -- ) global 1array set-namestack ;
|
||||||
|
|
Loading…
Reference in New Issue