prettyprinter recursion limit; better inspector

library/httpd/httpd.factor

@@ -80,10 +80,10 @@ USE: url-encoding
     ] with-stream ;
 
 : quit-flag ( -- ? )
-    "httpd-quit" get ;
+    global [ "httpd-quit" get ] bind ;
 
 : clear-quit-flag ( -- )
-    "httpd-quit" off ;
+    global [ "httpd-quit" off ] bind ;
 
 : httpd-loop ( server -- server )
     [

library/init.factor

@@ -29,6 +29,7 @@ IN: init
 USE: combinators
 USE: compiler
 USE: continuations
+USE: errors
 USE: interpreter
 USE: kernel
 USE: lists
@@ -84,9 +85,13 @@ USE: strings
 : init-interpreter ( -- )
     #! If we're run stand-alone, start the interpreter on stdio.
     "interactive" get [
-        [ "top-level-continuation" set ] callcc0
+        [
+            [ "top-level-continuation" set ] callcc0
 
-        interpreter-loop
+            interpreter-loop
+        ] [
+            default-error-handler
+        ] catch
     ] [
         f "top-level-continuation" set
     ] ifte ;

library/inspect-vocabularies.factor

@@ -67,14 +67,6 @@ USE: words
     #! List all usages of a word in all vocabularies.
     intern vocabs [ dupd usages-in-vocab. ] each drop ;
 
-: vocabs. ( -- )
-    #! List vocabularies.
-    "vocabularies" describe-object-path ;
-
-: words. ( vocab -- )
-    #! List a vocabulary.
-    "vocabularies'" swap cat2 describe-object-path ;
-
 : vocab-apropos ( substring vocab -- list )
     #! Push a list of all words in a vocabulary whose names
     #! contain a string.

library/inspector.factor

@@ -29,6 +29,7 @@ IN: inspector
 USE: combinators
 USE: format
 USE: kernel
+USE: hashtables
 USE: lists
 USE: namespaces
 USE: stack
@@ -52,19 +53,25 @@ USE: vocabularies
     uncons unparse swap relative>absolute-object-path
     default-style clone [ "link" set write-attr ] bind ;
 
-: value. ( max [ name | value ] -- )
-    dup [ car tuck pad-string write write ] dip
-    ": " write
-    var. terpri ;
+: var-name. ( max name -- )
+    default-style clone [
+        tuck pad-string write
+        dup relative>absolute-object-path "link" set
+        write-attr
+    ] bind ;
 
-: describe-banner ( obj -- )
-    "OBJECT: " write dup .
-    "CLASS : " write class-of print
-    "-------" print ;
+: value. ( max name value -- )
+    >r var-name. ": " write r> . ;
 
+: describe-assoc ( alist -- )
+    dup [ car ] inject max-str-length swap
+    [ dupd uncons value. ] each drop ;
+   
 : describe-namespace ( namespace -- )
-    [ vars max-str-length vars-values ] bind
-    [ dupd value. ] each drop ;
+    [ vars-values ] bind describe-assoc ;
+
+: describe-hashtable ( hashtables -- )
+    hash>alist describe-assoc ;
 
 : describe ( obj -- )
     [
@@ -74,8 +81,14 @@ USE: vocabularies
         [ string? ]
         [ print ]
         
+        [ assoc? ]
+        [ describe-assoc ]
+        
+        [ hashtable? ]
+        [ describe-hashtable ]
+        
         [ has-namespace? ]
-        [ dup describe-banner describe-namespace ]
+        [ describe-namespace ]
         
         [ drop t ]
         [ prettyprint ]

library/platform/native/boot.factor

@@ -103,7 +103,8 @@ primitives,
     max 2list length reverse nth list? 2rlist
     all? clone-list clone-list-iter subset subset-iter
     subset-add car= cdr= cons= cons-hashcode
-    tree-contains? =-or-contains? last* last inject
+    tree-contains? =-or-contains? 
+    last* last inject
 ] [ worddef worddef, ] each
 
 version,

library/platform/native/init.factor

@@ -58,6 +58,7 @@ USE: unparser
     t "interactive" set
     
     init-stdio
+    "stdio" get <ansi-stream> "stdio" set
     init-errors
     init-search-path
     init-scratchpad

library/prettyprint.factor

@@ -48,6 +48,10 @@ USE: words
     #! Change this to suit your tastes.
     4 ;
 
+: prettyprint-limit ( -- limit )
+    #! Avoid infinite loops -- maximum indent, 10 levels.
+    "prettyprint-limit" get [ 40 ] unless* ;
+
 : prettyprint-indent ( indent -- )
     #! Print the given number of spaces.
     " " fill write ;
@@ -85,15 +89,32 @@ DEFER: prettyprint*
         dup prettyprint-newline
     ] unless ;
 
+: check-recursion ( indent obj quot -- )
+    >r over prettyprint-limit >= [
+        r> drop drop "#< ... >" write
+    ] [
+        r> call
+    ] ifte ;
+
 : prettyprint-[ ( indent -- indent )
     "[" write <prettyprint ;
 
 : prettyprint-] ( indent -- indent )
     prettyprint> "]" write ;
 
+: (prettyprint-list) ( indent list -- indent )
+    uncons >r prettyprint-element r>
+    dup cons? [
+        (prettyprint-list)
+    ] [
+        [
+            "|" write prettyprint-space prettyprint-element
+        ] when*
+    ] ifte ;
+
 : prettyprint-list ( indent list -- indent )
     #! Pretty-print a list, without [ and ].
-    [ prettyprint-element ] each ;
+    [ (prettyprint-list) ] check-recursion ;
 
 : prettyprint-[] ( indent list -- indent )
     swap prettyprint-[ swap prettyprint-list prettyprint-] ;
@@ -106,7 +127,7 @@ DEFER: prettyprint*
 
 : prettyprint-vector ( indent list -- indent )
     #! Pretty-print a vector, without { and }.
-    [ prettyprint-element ] vector-each ;
+    [ [ prettyprint-element ] vector-each ] check-recursion ;
 
 : prettyprint-{} ( indent list -- indent )
     swap prettyprint-{ swap prettyprint-vector prettyprint-} ;
@@ -142,7 +163,7 @@ DEFER: prettyprint*
 : prettyprint* ( indent obj -- indent )
     [
         [ f =       ] [ prettyprint-object ]
-        [ list?     ] [ prettyprint-[] ]
+        [ cons?     ] [ prettyprint-[] ]
         [ vector?   ] [ prettyprint-{} ]
         [ comment?  ] [ prettyprint-comment ]
         [ word?     ] [ prettyprint-word ]
@@ -168,7 +189,9 @@ DEFER: prettyprint*
 
 : . ( obj -- )
     <namespace> [
-        "prettyprint-single-line" on prettyprint
+        "prettyprint-single-line" on
+        prettyprint-indent 4 * "prettyprint-limit" set
+        prettyprint
     ] bind ;
 
 : [.] ( list -- )

native/error.h

@@ -8,6 +8,7 @@
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);
 void fix_stacks(void);
+void check_stacks(void);
 void throw_error(CELL object);
 void general_error(CELL error, CELL tagged);
 void type_error(CELL type, CELL tagged);

native/factor.h

@@ -20,7 +20,7 @@
 
 /* Memory heap size */
 #define DEFAULT_ARENA (4 * 1024 * 1024)
-#define STACK_SIZE 256
+#define STACK_SIZE 1024
 
 #include "error.h"
 #include "memory.h"

native/run.c

@@ -7,18 +7,6 @@ void clear_environment(void)
 		env.user[i] = 0;
 }
 
-void reset_datastack(void)
-{
-	env.ds = UNTAG(env.ds_bot) + sizeof(ARRAY);
-	env.dt = empty;
-}
-
-void reset_callstack(void)
-{
-	env.cs = UNTAG(env.cs_bot) + sizeof(ARRAY);
-	cpush(empty);
-}
-
 void init_environment(void)
 {
 	/* + CELLS * 2 to skip header and length cell */
@@ -40,6 +28,8 @@ void run(void)
 	
 	for(;;)
 	{
+		check_stacks();
+		
 		if(env.cf == F)
 		{
 			if(cpeek() == empty)

native/stack.c

@@ -1,5 +1,17 @@
 #include "factor.h"
 
+void reset_datastack(void)
+{
+	env.ds = UNTAG(env.ds_bot) + sizeof(ARRAY);
+	env.dt = empty;
+}
+
+void reset_callstack(void)
+{
+	env.cs = UNTAG(env.cs_bot) + sizeof(ARRAY);
+	cpush(empty);
+}
+
 void primitive_drop(void)
 {
 	check_non_empty(env.dt);

native/stack.h

@@ -1,3 +1,22 @@
+#define UNDERFLOW_CHECKING
+
+#define OVERFLOW(stack,bot) ((stack) >= UNTAG(bot) + object_size(bot))
+
+INLINE void check_stacks(void)
+{
+
+#ifdef UNDERFLOW_CHECKING
+	if(OVERFLOW(env.ds,env.ds_bot))
+		fatal_error("datastack overflow",env.ds);
+	if(OVERFLOW(env.cs,env.cs_bot))
+		fatal_error("callstack overflow",env.ds);
+#endif
+
+}
+
+void reset_datastack(void);
+void reset_callstack(void);
+
 void primitive_drop(void);
 void primitive_dup(void);
 void primitive_swap(void);