fixing various bugs
parent
11552b0254
commit
b7992f93a5
|
@ -1,7 +1,6 @@
|
||||||
+ 0.80:
|
+ 0.80:
|
||||||
|
|
||||||
- zero-height gadgets mess up hit testing
|
- zero-height gadgets mess up hit testing
|
||||||
- make-image leaks memory
|
|
||||||
- does parsing cons excessive amounts of bignums with c-streams
|
- does parsing cons excessive amounts of bignums with c-streams
|
||||||
- -with combinators are awkward
|
- -with combinators are awkward
|
||||||
- cleanups:
|
- cleanups:
|
||||||
|
|
|
@ -130,18 +130,6 @@ SYMBOL: current-node
|
||||||
dup dataflow-graph set current-node set
|
dup dataflow-graph set current-node set
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: nest-node ( -- dataflow current )
|
|
||||||
dataflow-graph get dataflow-graph off
|
|
||||||
current-node get current-node off ;
|
|
||||||
|
|
||||||
: unnest-node ( new-node dataflow current -- new-node )
|
|
||||||
>r >r dataflow-graph get 1array over set-node-children
|
|
||||||
r> dataflow-graph set
|
|
||||||
r> current-node set ;
|
|
||||||
|
|
||||||
: with-nesting ( quot -- new-node | quot: -- new-node )
|
|
||||||
nest-node 2slip unnest-node ; inline
|
|
||||||
|
|
||||||
: node-values ( node -- values )
|
: node-values ( node -- values )
|
||||||
[
|
[
|
||||||
dup node-in-d % dup node-out-d %
|
dup node-in-d % dup node-out-d %
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: inference
|
IN: inference
|
||||||
USING: errors generic interpreter kernel lists math
|
USING: arrays errors generic hashtables interpreter kernel lists
|
||||||
math-internals namespaces sequences strings vectors words
|
math math-internals namespaces parser prettyprint sequences
|
||||||
hashtables parser prettyprint ;
|
strings vectors words ;
|
||||||
|
|
||||||
: consume-values ( n node -- )
|
: consume-values ( n node -- )
|
||||||
over ensure-values
|
over ensure-values
|
||||||
|
@ -27,21 +27,28 @@ hashtables parser prettyprint ;
|
||||||
|
|
||||||
TUPLE: rstate label quot base-case? ;
|
TUPLE: rstate label quot base-case? ;
|
||||||
|
|
||||||
|
: nest-node ( -- dataflow current )
|
||||||
|
dataflow-graph get dataflow-graph off
|
||||||
|
current-node get current-node off ;
|
||||||
|
|
||||||
|
: unnest-node ( new-node dataflow current -- new-node )
|
||||||
|
>r >r dataflow-graph get 1array over set-node-children
|
||||||
|
r> dataflow-graph set
|
||||||
|
r> current-node set ;
|
||||||
|
|
||||||
: with-recursive-state ( word label base-case quot -- )
|
: with-recursive-state ( word label base-case quot -- )
|
||||||
>r >r over word-def r> <rstate> cons
|
>r >r over word-def r> <rstate> cons
|
||||||
recursive-state [ cons ] change r>
|
recursive-state [ cons ] change r>
|
||||||
call ; inline
|
nest-node 2slip unnest-node ; inline
|
||||||
|
|
||||||
: inline-block ( word base-case -- node-block variables )
|
: inline-block ( word base-case -- node-block variables )
|
||||||
[
|
[
|
||||||
copy-inference
|
copy-inference
|
||||||
>r gensym 2dup r> [
|
>r gensym 2dup r> [
|
||||||
[
|
|
||||||
dup #label >r
|
dup #label >r
|
||||||
#entry node,
|
#entry node,
|
||||||
swap word-def infer-quot
|
swap word-def infer-quot
|
||||||
#return node, r>
|
#return node, r>
|
||||||
] with-nesting
|
|
||||||
] with-recursive-state
|
] with-recursive-state
|
||||||
] make-hash ;
|
] make-hash ;
|
||||||
|
|
||||||
|
|
|
@ -19,7 +19,9 @@ SYMBOL: stdio
|
||||||
: break ( -- ) stdio get stream-break ;
|
: break ( -- ) stdio get stream-break ;
|
||||||
: terpri ( -- ) stdio get stream-terpri ;
|
: terpri ( -- ) stdio get stream-terpri ;
|
||||||
: format ( string style -- ) stdio get stream-format ;
|
: format ( string style -- ) stdio get stream-format ;
|
||||||
: with-nesting ( style quot -- ) stdio get with-nested-stream ;
|
|
||||||
|
: with-nesting ( style quot -- )
|
||||||
|
swap stdio get with-nested-stream ;
|
||||||
|
|
||||||
: print ( string -- ) stdio get stream-print ;
|
: print ( string -- ) stdio get stream-print ;
|
||||||
|
|
||||||
|
|
|
@ -22,7 +22,7 @@ GENERIC: stream-flush ( stream -- )
|
||||||
GENERIC: stream-break ( stream -- )
|
GENERIC: stream-break ( stream -- )
|
||||||
GENERIC: stream-terpri ( stream -- )
|
GENERIC: stream-terpri ( stream -- )
|
||||||
GENERIC: stream-format ( string style stream -- )
|
GENERIC: stream-format ( string style stream -- )
|
||||||
GENERIC: with-nested-stream ( style stream quot -- )
|
GENERIC: with-nested-stream ( quot style stream -- )
|
||||||
|
|
||||||
: stream-print ( string stream -- )
|
: stream-print ( string stream -- )
|
||||||
[ stream-write ] keep stream-terpri ;
|
[ stream-write ] keep stream-terpri ;
|
||||||
|
|
|
@ -37,5 +37,4 @@ SYMBOL: outline
|
||||||
! Paragraph styles
|
! Paragraph styles
|
||||||
SYMBOL: border-color
|
SYMBOL: border-color
|
||||||
SYMBOL: border-width
|
SYMBOL: border-width
|
||||||
SYMBOL: padding
|
|
||||||
SYMBOL: word-wrap
|
SYMBOL: word-wrap
|
||||||
|
|
|
@ -131,8 +131,8 @@ M: pane stream-readln ( pane -- line )
|
||||||
M: pane stream-write1 ( char pane -- )
|
M: pane stream-write1 ( char pane -- )
|
||||||
[ pane-current stream-write1 ] keep scroll-pane ;
|
[ pane-current stream-write1 ] keep scroll-pane ;
|
||||||
|
|
||||||
M: pane stream-write ( string style pane -- )
|
M: pane stream-write ( string pane -- )
|
||||||
[ rot "\n" split pane-write ] keep scroll-pane ;
|
[ swap "\n" split pane-write ] keep scroll-pane ;
|
||||||
|
|
||||||
M: pane stream-format ( string style pane -- )
|
M: pane stream-format ( string style pane -- )
|
||||||
[ rot "\n" split pane-format ] keep scroll-pane ;
|
[ rot "\n" split pane-format ] keep scroll-pane ;
|
||||||
|
@ -154,6 +154,3 @@ M: pane stream-close ( pane -- ) drop ;
|
||||||
#! Clear the pane and run the quotation in a scope with
|
#! Clear the pane and run the quotation in a scope with
|
||||||
#! stdio set to the pane.
|
#! stdio set to the pane.
|
||||||
>r dup pane-clear r> with-stream* ; inline
|
>r dup pane-clear r> with-stream* ; inline
|
||||||
|
|
||||||
M: pane with-nested-stream ( style stream quot -- )
|
|
||||||
-rot >r >r make-pane r> drop r> pane-current add-gadget ;
|
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets-presentations
|
IN: gadgets-presentations
|
||||||
USING: arrays compiler gadgets gadgets-buttons gadgets-labels
|
USING: arrays compiler gadgets gadgets-borders gadgets-buttons
|
||||||
gadgets-layouts gadgets-menus gadgets-outliner gadgets-panes
|
gadgets-labels gadgets-layouts gadgets-menus gadgets-outliner
|
||||||
gadgets-theme generic hashtables inference inspector io jedit
|
gadgets-panes gadgets-theme generic hashtables inference
|
||||||
kernel lists memory namespaces parser prettyprint sequences
|
inspector io jedit kernel lists memory namespaces parser
|
||||||
strings styles words ;
|
prettyprint sequences strings styles words ;
|
||||||
|
|
||||||
SYMBOL: commands
|
SYMBOL: commands
|
||||||
|
|
||||||
|
@ -83,6 +83,15 @@ M: gadget-stream stream-break ( stream -- )
|
||||||
|
|
||||||
M: gadget-stream stream-close ( stream -- ) drop ;
|
M: gadget-stream stream-close ( stream -- ) drop ;
|
||||||
|
|
||||||
|
: paragraph-style ( pane style -- pane )
|
||||||
|
border-width over hash [ >r <border> r> ] when
|
||||||
|
border-color swap hash
|
||||||
|
[ <solid> over set-gadget-boundary ] when* ;
|
||||||
|
|
||||||
|
M: pane with-nested-stream ( quot style stream -- )
|
||||||
|
>r >r make-pane r> paragraph-style
|
||||||
|
r> pane-current add-gadget ;
|
||||||
|
|
||||||
[ drop t ] "Prettyprint" [ . ] define-command
|
[ drop t ] "Prettyprint" [ . ] define-command
|
||||||
[ drop t ] "Describe" [ describe ] define-command
|
[ drop t ] "Describe" [ describe ] define-command
|
||||||
[ drop t ] "Push on data stack" [ ] define-command
|
[ drop t ] "Push on data stack" [ ] define-command
|
||||||
|
|
Loading…
Reference in New Issue