- word preview for remote words\r
- support USING:\r
- special completion for USE:/IN:\r
-- prettyprint: detect circular structure\r
- vectors: ensure its ok with bignum indices\r
-- parsing words don't print readably\r
- if gadgets are moved, added or deleted, update hand.\r
- keyboard focus\r
- keyboard gestures\r
- ffi unicode strings: null char security hole\r
- utf16 string boxing\r
- slot compile problem\r
-- nulls at the end of utf16 strings\r
+- sdl console crash\r
- x86 register decl\r
\r
+ compiler/ffi:\r
: append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
over [ >r uncons r> append cons ] [ nip ] ifte ;
-: contains? ( element list -- ? )
- #! Test if a list contains an element.
+: contains? ( obj list -- ? )
+ #! Test if a list contains an element equal to an object.
[ = ] some-with? >boolean ;
+: memq? ( obj list -- ? )
+ #! Test if a list contains an object.
+ [ eq? ] some-with? >boolean ;
+
: partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
rot [ swapd cons ] [ >r cons r> ] ifte ;
! to the generic vocabulary.
USING: errors generic kernel kernel-internals lists math
namespaces stdio strings presentation unparser vectors words
-hashtables ;
+hashtables parser ;
SYMBOL: prettyprint-limit
SYMBOL: one-line
SYMBOL: tab-size
+SYMBOL: recursion-check
GENERIC: prettyprint* ( indent obj -- indent )
M: object prettyprint* ( indent obj -- indent )
unparse write ;
-: indent ( indent -- )
- #! Print the given number of spaces.
- " " fill write ;
-
-: prettyprint-newline ( indent -- )
- "\n" write indent ;
-
-: prettyprint-element ( indent obj -- indent )
- over prettyprint-limit get >= [
- unparse write
- ] [
- prettyprint*
- ] ifte " " write ;
-
-: <prettyprint ( indent -- indent )
- tab-size get + one-line get [
- " " write
- ] [
- dup prettyprint-newline
- ] ifte ;
-
-: prettyprint> ( indent -- indent )
- tab-size get - one-line get
- [ dup prettyprint-newline ] unless ;
-
: word-link ( word -- link )
[
dup word-name unparse ,
drop [ ]
] ifte ;
-M: word prettyprint* ( indent word -- indent )
+: prettyprint-word ( word -- )
dup word-name
swap dup word-attrs swap word-style append
write-attr ;
+M: word prettyprint* ( indent word -- indent )
+ dup parsing? [
+ \ POSTPONE: prettyprint-word " " write
+ ] when
+ prettyprint-word ;
+
+: indent ( indent -- )
+ #! Print the given number of spaces.
+ " " fill write ;
+
+: prettyprint-newline ( indent -- )
+ "\n" write indent ;
+
+: prettyprint-elements ( indent list -- indent )
+ [ prettyprint* " " write ] each ;
+
+: <prettyprint ( indent -- indent )
+ tab-size get + one-line get [
+ " " write
+ ] [
+ dup prettyprint-newline
+ ] ifte ;
+
+: prettyprint> ( indent -- indent )
+ tab-size get - one-line get
+ [ dup prettyprint-newline ] unless ;
+
+: prettyprint-limit? ( indent -- ? )
+ prettyprint-limit get dup [ >= ] [ nip ] ifte ;
+
+: check-recursion ( indent obj quot -- ? indent )
+ #! We detect circular structure.
+ pick prettyprint-limit? >r
+ over recursion-check get memq? r> or [
+ 2drop "..." write
+ ] [
+ over recursion-check [ cons ] change
+ call
+ recursion-check [ cdr ] change
+ ] ifte ;
+
: prettyprint-sequence ( indent start list end -- indent )
#! Prettyprint a list, with start/end delimiters; eg, [ ],
#! or { }, or << >>. The body of the list is indented,
#! unless the list is empty.
over [
>r
- >r prettyprint* <prettyprint
- r> [ prettyprint-element ] each
- prettyprint> r> prettyprint*
+ >r prettyprint-word <prettyprint
+ r> prettyprint-elements
+ prettyprint> r> prettyprint-word
] [
- >r >r prettyprint* " " write r> drop r> prettyprint*
+ >r >r prettyprint-word " " write
+ r> drop
+ r> prettyprint-word
] ifte ;
M: list prettyprint* ( indent list -- indent )
- \ [ swap \ ] prettyprint-sequence ;
+ [
+ \ [ swap \ ] prettyprint-sequence
+ ] check-recursion ;
M: cons prettyprint* ( indent cons -- indent )
#! Here we turn the cons into a list of two elements.
- \ [[ swap uncons 2list \ ]] prettyprint-sequence ;
+ [
+ \ [[ swap uncons 2list \ ]] prettyprint-sequence
+ ] check-recursion ;
M: vector prettyprint* ( indent vector -- indent )
- \ { swap vector>list \ } prettyprint-sequence ;
+ [
+ \ { swap vector>list \ } prettyprint-sequence
+ ] check-recursion ;
M: hashtable prettyprint* ( indent hashtable -- indent )
- \ {{ swap hash>alist \ }} prettyprint-sequence ;
+ [
+ \ {{ swap hash>alist \ }} prettyprint-sequence
+ ] check-recursion ;
M: tuple prettyprint* ( indent tuple -- indent )
- \ << swap tuple>list \ >> prettyprint-sequence ;
-
-: prettyprint-1 ( obj -- )
- 0 swap prettyprint* drop ;
+ [
+ \ << swap tuple>list \ >> prettyprint-sequence
+ ] check-recursion ;
: prettyprint ( obj -- )
- prettyprint-1 terpri ;
+ [
+ recursion-check off
+ 0 swap prettyprint* drop terpri
+ ] with-scope ;
: vocab-link ( vocab -- link )
"vocabularies'" swap cat2 ;
: .o >oct print ;
: .h >hex print ;
-global [ 40 prettyprint-limit set 4 tab-size set ] bind
+global [ 4 tab-size set ] bind
dup vocab-attrs write-attr ;
: prettyprint-IN: ( word -- )
- \ IN: prettyprint* " " write
+ \ IN: prettyprint-word " " write
word-vocabulary prettyprint-vocab " " write ;
: prettyprint-: ( indent -- indent )
- \ : prettyprint* " " write
+ \ : prettyprint-word " " write
tab-size get + ;
: prettyprint-; ( indent -- indent )
- \ ; prettyprint*
+ \ ; prettyprint-word
tab-size get - ;
: prettyprint-prop ( word prop -- )
tuck word-name word-property [
- " " write prettyprint-1
+ " " write prettyprint-word
] [
drop
] ifte ;
] keep documentation. ;
: prettyprint-M: ( indent -- indent )
- \ M: prettyprint-1 " " write tab-size get + ;
+ \ M: prettyprint-word " " write tab-size get + ;
GENERIC: see ( word -- )
M: compound see ( word -- )
dup prettyprint-IN:
0 prettyprint-: swap
- [ prettyprint-1 ] keep
+ [ prettyprint-word ] keep
[ prettyprint-docs ] keep
[
- word-parameter [ prettyprint-element ] each
+ word-parameter prettyprint-elements
prettyprint-;
] keep
prettyprint-plist prettyprint-newline ;
: see-method ( indent word class method -- indent )
>r >r >r prettyprint-M:
- r> r> prettyprint-1 " " write
- prettyprint-1 " " write
+ r> r> prettyprint-word " " write
+ prettyprint-word " " write
dup prettyprint-newline
- r> [ prettyprint-element ] each
+ r> prettyprint-elements
prettyprint-;
terpri ;
M: generic see ( word -- )
dup prettyprint-IN:
0 swap
- dup "definer" word-property prettyprint-1 " " write
- dup prettyprint-1 terpri
+ dup "definer" word-property prettyprint-word " " write
+ dup prettyprint-word terpri
dup methods [ over >r uncons see-method r> ] each 2drop ;
M: primitive see ( word -- )
dup prettyprint-IN:
- "PRIMITIVE: " write dup prettyprint-1 stack-effect. terpri ;
+ "PRIMITIVE: " write dup prettyprint-word stack-effect.
+ terpri ;
M: symbol see ( word -- )
dup prettyprint-IN:
- \ SYMBOL: prettyprint-1 " " write . ;
+ \ SYMBOL: prettyprint-word " " write . ;
M: undefined see ( word -- )
dup prettyprint-IN:
- \ DEFER: prettyprint-1 " " write . ;
+ \ DEFER: prettyprint-word " " write . ;
: :get ( var -- value ) "error-namestack" get (get) ;
: debug-help ( -- )
- [ :s :r :n :c ] [ prettyprint-1 " " write ] each
+ [ :s :r :n :c ] [ prettyprint-word " " write ] each
"show stacks at time of error." print
- \ :get prettyprint-1
+ \ :get prettyprint-word
" ( var -- value ) inspects the error namestack." print ;
: flush-error-handler ( error -- )
: walk-banner ( -- )
"The following words control the single-stepper:" print
- [ &s &r &n &c ] [ prettyprint-1 " " write ] each
+ [ &s &r &n &c ] [ prettyprint-word " " write ] each
"show stepper stacks." print
- \ &get prettyprint-1
+ \ &get prettyprint-word
" ( var -- value ) inspects the stepper namestack." print
- \ step prettyprint-1 " -- single step over" print
- \ into prettyprint-1 " -- single step into" print
- \ (trace) prettyprint-1 " -- trace until end" print
- \ (run) prettyprint-1 " -- run until end" print
- \ exit prettyprint-1 " -- exit single-stepper" print ;
+ \ step prettyprint-word " -- single step over" print
+ \ into prettyprint-word " -- single step into" print
+ \ (trace) prettyprint-word " -- trace until end" print
+ \ (run) prettyprint-word " -- run until end" print
+ \ exit prettyprint-word " -- exit single-stepper" print ;
: walk ( quot -- )
#! Single-step through execution of a quotation.