diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 9733f8c6e5..95089dffba 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -9,9 +9,7 @@ - word preview for remote words - support USING: - special completion for USE:/IN: -- prettyprint: detect circular structure - vectors: ensure its ok with bignum indices -- parsing words don't print readably - if gadgets are moved, added or deleted, update hand. - keyboard focus - keyboard gestures @@ -32,7 +30,7 @@ - ffi unicode strings: null char security hole - utf16 string boxing - slot compile problem -- nulls at the end of utf16 strings +- sdl console crash - x86 register decl + compiler/ffi: diff --git a/library/lists.factor b/library/lists.factor index f1cea1f255..e3b313d6c2 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -17,10 +17,14 @@ IN: lists USING: generic kernel math ; : 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 ; diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 7ddcd92516..dacf88bb18 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -7,42 +7,18 @@ IN: prettyprint ! 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 ; - -: ( indent -- indent ) - tab-size get - one-line get - [ dup prettyprint-newline ] unless ; - : word-link ( word -- link ) [ dup word-name unparse , @@ -69,45 +45,98 @@ M: object prettyprint* ( indent obj -- indent ) 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 ; + +: ( 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-element ] each - prettyprint> r> prettyprint* + >r prettyprint-word 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 ; @@ -137,4 +166,4 @@ M: tuple prettyprint* ( indent tuple -- indent ) : .o >oct print ; : .h >hex print ; -global [ 40 prettyprint-limit set 4 tab-size set ] bind +global [ 4 tab-size set ] bind diff --git a/library/syntax/see.factor b/library/syntax/see.factor index abf7c593d3..c02d8039f1 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -21,20 +21,20 @@ presentation unparser words ; 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 ; @@ -83,45 +83,46 @@ presentation unparser words ; ] 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 . ; diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 29fe864382..fdf12c0795 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -145,9 +145,9 @@ M: object error. ( error -- ) : :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 -- ) diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 7955f3050c..a523e06ede 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -201,15 +201,15 @@ SYMBOL: meta-cf : 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.