type inference changes, comment out smart-terminal reference in win32-console, win32-compatible factor plugin

TODO.FACTOR.txt

@@ -34,6 +34,10 @@
 
 + listener/plugin:
 
+- listener should be multithreaded
+- fully socket based communication
+- compile all, infer all commands
+- type something -- no completions -- hit another key -- not inserted
 - faster completion
 - sidekick: still parsing too much
 - errors don't always disappear

examples/infix.factor

@@ -8,7 +8,7 @@ USE: words
 
 : vector-peek ( vector -- obj )
     #! Get value at end of vector without removing it.
-    dup vector-length pred swap vector-nth ;
+    dup vector-length 1 - swap vector-nth ;
 
 SYMBOL: exprs
 DEFER: infix

examples/mandel.factor

@@ -44,7 +44,7 @@ USE: test
 : <color-map> ( nb-cols -- map )
     [
         dup [
-            360 * over succ / 360 / sat val
+            360 * over 1 + / 360 / sat val
             hsv>rgb 1.0 scale-rgba ,
         ] times*
     ] make-list list>vector nip ;
@@ -55,7 +55,7 @@ USE: test
     over absq 4 >= over 0 = or [
         nip nip
     ] [
-        pred >r sq dupd + r> iter
+        1 - >r sq dupd + r> iter
     ] ifte ;
 
 : max-color 360 ;

examples/more-random.factor

@@ -14,7 +14,7 @@ USE: namespaces
 
 : random-element ( list -- random )
     #! Returns a random element from the given list.
-    dup >r length pred 0 swap random-int r> nth ;
+    dup >r length 1 - 0 swap random-int r> nth ;
 
 : random-subset ( list -- list )
     #! Returns a random subset of the given list. Each item is

factor/ExternalFactor.java

@@ -40,41 +40,57 @@ import org.gjt.sp.util.Log;
 public class ExternalFactor extends DefaultVocabularyLookup
 {
 	//{{{ ExternalFactor constructor
-	/**
+	public ExternalFactor(int port)
-	 * We are given two streams that point to a bare REPL.
-	 */
-	public ExternalFactor(Process proc, InputStream in, OutputStream out)
 	{
-		if(proc == null || in == null || out == null)
+		/* Start stream server */;
-			closed = true;
+		streamServer = port;
-		else
-		{
-			this.proc = proc;
 
+		for(int i = 1; i < 6; i++)
+		{
+			Log.log(Log.DEBUG,this,"Factor connection, try #" + i);
 			try
 			{
-				this.in = new DataInputStream(in);
+				Thread.sleep(1000);
-				this.out = new DataOutputStream(out);
+				openWire();
-
+				Log.log(Log.DEBUG,this,"Connection established");
-				out.write("USE: jedit wire-server\n".getBytes("ASCII"));
+				return;
-				out.flush();
-
-				waitForAck();
-
-				/* Start stream server */
-				streamServer = 9999;
-				eval("USE: telnetd [ 9999 telnetd ] in-thread");
-
-				/* Ensure we're ready for a connection immediately */
-				eval("nop");
 			}
 			catch(Exception e)
 			{
+				Log.log(Log.ERROR,this,e);
+			}
+			
+		}
+
+		Log.log(Log.ERROR,this,"Cannot connect to Factor on port " + port);
+		if(in != null && out != null)
 			close();
-			}
-		}
 	} //}}}
 
+	//{{{ openWireSocket() method
+	/**
+	 * Return a listener stream.
+	 */
+	public Socket openWireSocket() throws IOException
+	{
+		if(closed)
+			throw new IOException("Socket closed");
+		return new Socket("localhost",streamServer);
+	} //}}}
+
+	//{{{ openWire() method
+	private void openWire() throws Exception
+	{
+		Socket client = openWireSocket();
+		in = new DataInputStream(new BufferedInputStream(
+			client.getInputStream()));
+		out = new DataOutputStream(new BufferedOutputStream(
+			client.getOutputStream()));
+		out.write("USE: jedit wire-server\n".getBytes("ASCII"));
+		out.flush();
+		waitForAck();
+	}
+
 	//{{{ waitForAck() method
 	private void waitForAck() throws IOException
 	{
@@ -131,15 +147,10 @@ public class ExternalFactor extends DefaultVocabularyLookup
 	 * Return a listener stream.
 	 */
 	public FactorStream openStream()
-	{
-		if(closed)
-			return null;
-		else
 	{
 		try
 		{
-				Socket client = new Socket("localhost",streamServer);
+			return new FactorStream(openWireSocket());
-				return new FactorStream(client);
 		}
 		catch(Exception e)
 		{
@@ -148,7 +159,6 @@ public class ExternalFactor extends DefaultVocabularyLookup
 			Log.log(Log.ERROR,this,e);
 			return null;
 		}
-		}
 	} //}}}
 
 	//{{{ getVocabularies() method
@@ -279,7 +289,6 @@ public class ExternalFactor extends DefaultVocabularyLookup
 		
 		try
 		{
-			proc.waitFor();
 			in.close();
 			out.close();
 		}
@@ -289,7 +298,6 @@ public class ExternalFactor extends DefaultVocabularyLookup
 			Log.log(Log.DEBUG,this,e);
 		}
 
-		proc = null;
 		in = null;
 		out = null;
 	} //}}}
@@ -303,7 +311,6 @@ public class ExternalFactor extends DefaultVocabularyLookup
 	//{{{ Private members
 	private boolean closed;
 
-	private Process proc;
 	private DataInputStream in;
 	private DataOutputStream out;
 	

factor/jedit/FactorPlugin.java

@@ -42,6 +42,8 @@ import sidekick.*;
 public class FactorPlugin extends EditPlugin
 {
 	private static ExternalFactor external;
+	private static Process process;
+	private static int PORT = 9999;
 
 	//{{{ getPluginPath() method
 	private String getPluginPath()
@@ -101,7 +103,6 @@ public class FactorPlugin extends EditPlugin
 	{
 		if(external == null)
 		{
-			Process p = null;
 			InputStream in = null;
 			OutputStream out = null;
 
@@ -110,27 +111,28 @@ public class FactorPlugin extends EditPlugin
 				List args = new ArrayList();
 				args.add(jEdit.getProperty("factor.external.program"));
 				args.add(jEdit.getProperty("factor.external.image"));
-				args.add("-no-ansi");
+				args.add("-shell=telnet");
-				args.add("-no-smart-terminal");
+				args.add("-telnetd-port=" + PORT);
 				String[] extraArgs = jEdit.getProperty(
-					"factor.external.args","-jedit")
+					"factor.external.args")
 					.split(" ");
 				addNonEmpty(extraArgs,args);
-				p = Runtime.getRuntime().exec((String[])args.toArray(
+				process = Runtime.getRuntime().exec((String[])args.toArray(
 					new String[args.size()]));
-				p.getErrorStream().close();
 
-				in = p.getInputStream();
+				external = new ExternalFactor(PORT);
-				out = p.getOutputStream();
+
+				process.getErrorStream().close();
+				process.getInputStream().close();
+				process.getOutputStream().close();
 			}
-			catch(IOException io)
+			catch(Exception e)
 			{
 				Log.log(Log.ERROR,FactorPlugin.class,
 					"Cannot start external Factor:");
-				Log.log(Log.ERROR,FactorPlugin.class,io);
+				Log.log(Log.ERROR,FactorPlugin.class,e);
+				process = null;
 			}
-
-			external = new ExternalFactor(p,in,out);
 		}
 
 		return external;
@@ -153,6 +155,14 @@ public class FactorPlugin extends EditPlugin
 		if(external != null)
 		{
 			external.close();
+			try
+			{
+				process.waitFor();
+			}
+			catch(Exception e)
+			{
+				Log.log(Log.DEBUG,FactorPlugin.class,e);
+			}
 			external = null;
 		}
 	} //}}}

library/bootstrap/boot-stage2.factor

@@ -114,8 +114,8 @@ USE: namespaces
 
     "/library/inference/dataflow.factor"
     "/library/inference/inference.factor"
-    "/library/inference/words.factor"
     "/library/inference/branches.factor"
+    "/library/inference/words.factor"
     "/library/inference/stack.factor"
 
     "/library/compiler/assembler.factor"

library/bootstrap/init-stage2.factor

@@ -45,10 +45,19 @@ USE: unparser
 USE: kernel-internals
 USE: console
 
-: init-smart-terminal
+: default-cli-args
-    "smart-terminal" get [
+    #! Some flags are *on* by default, unless user specifies
-        stdio smart-term-hook get change 
+    #! -no-<flag> CLI switch
-    ] when ;
+    "user-init" on
+    "interactive" on
+    "smart-terminal" on
+    "verbose-compile" on
+    "compile" on
+    os "win32" = [
+        "sdl" "shell" set
+    ] [
+        "ansi" "shell" set
+    ] ifte ;
 
 : warm-boot ( -- )
     #! A fully bootstrapped image has this as the boot
@@ -59,18 +68,15 @@ USE: console
     default-cli-args
     parse-command-line ;
 
+: shell ( str -- )
+    #! This handles the -shell:<foo> cli argument.
+    [ "shells" ] search execute ;
+
 [
     warm-boot
     garbage-collection
     run-user-init
-    "graphical" get [
+    "shell" get shell
-        start-console
-    ] [
-        "interactive" get [
-            init-smart-terminal
-            print-banner listener
-        ] when
-    ] ifte
     0 exit* 
 ] set-boot
 
@@ -136,10 +142,10 @@ terpri
 "Not every word compiles, by design." print
 terpri
 
-0 [ compiled? [ succ ] when ] each-word
+0 [ compiled? [ 1 + ] when ] each-word
 unparse write " words compiled" print
 
-0 [ drop succ ] each-word
+0 [ drop 1 + ] each-word
 unparse write " words total" print 
 
 "Bootstrapping is complete." print

library/bootstrap/primitives.factor

@@ -223,5 +223,5 @@ vocabularies get [
     [ "kernel-internals" | "set-integer-slot" ]
     [ "kernel-internals" | "grow-array" ]
 ] [
-    unswons create swap succ [ f define ] keep
+    unswons create swap 1 + [ f define ] keep
 ] each drop

library/cli.factor

@@ -82,16 +82,6 @@ USE: kernel-internals
 : run-files ( args -- )
     [ [ run-file ] when* ] each ;
 
-: default-cli-args
-    #! Some flags are *on* by default, unless user specifies
-    #! -no-<flag> CLI switch
-    "user-init" on
-    "interactive" on
-    "smart-terminal" on
-    "verbose-compile" on
-    "compile" on
-    os "win32" = [ "graphical" on ] when ;
-
 : cli-args ( -- args ) 10 getenv ;
 
 : parse-command-line ( -- )

library/compiler/alien-types.factor

@@ -53,7 +53,7 @@ USE: words
     scan str>number ; parsing
 
 : ENUM:
-    dup CREATE swap unit define-compound succ ; parsing
+    dup CREATE swap unit define-compound 1 + ; parsing
 
 : END-ENUM
     drop ; parsing

library/generic/builtin.factor

@@ -77,9 +77,6 @@ builtin 50 "priority" set-word-property
 : builtin-type ( n -- symbol )
     unit classes get hash ;
 
-: type-name ( n -- string )
-    builtin-type word-name ;
-
 : class ( obj -- class )
     #! Analogous to the type primitive. Pushes the builtin
     #! class of an object.

library/generic/generic.factor

@@ -118,6 +118,9 @@ USE: math-internals
         dup <namespace> [ "methods" set-word-property ] keep
     ] unless* <vtable> define-generic ;
 
+PREDICATE: word generic ( word -- ? )
+    "combination" word-property ;
+
 : single-combination ( obj vtable -- )
     >r dup type r> dispatch ; inline
 

library/gensym.factor

@@ -36,7 +36,7 @@ SYMBOL: gensym-count
 
 : (gensym) ( -- name )
     "G:" global [
-        gensym-count [ succ dup ] change
+        gensym-count [ 1 + dup ] change
     ] bind unparse cat2 ;
 
 : gensym ( -- word )

library/httpd/url-encoding.factor

@@ -49,14 +49,14 @@ USE: unparser
     2dup str-length 2 - >= [
         2drop
     ] [
-        >r succ dup 2 + r> substring  catch-hex> [ , ] when*
+        >r 1 + dup 2 + r> substring  catch-hex> [ , ] when*
     ] ifte ;
 
 : url-decode-% ( index str -- index str )
     2dup url-decode-hex >r 3 + r> ;
 
 : url-decode-+-or-other ( index str ch -- index str )
-    dup CHAR: + = [ drop CHAR: \s ] when , >r succ r> ;
+    dup CHAR: + = [ drop CHAR: \s ] when , >r 1 + r> ;
 
 : url-decode-iter ( index str -- )
     2dup str-length >= [

library/inference/branches.factor

@@ -39,10 +39,6 @@ USE: words
 USE: hashtables
 USE: prettyprint
 
-! If this symbol is on, partial evalution of conditionals is
-! disabled.
-SYMBOL: inferring-base-case
-
 : vector-length< ( vec1 vec2 -- ? )
     swap vector-length swap vector-length < ;
 
@@ -65,7 +61,11 @@ SYMBOL: inferring-base-case
 : unify-results ( value value -- value )
     #! Replace values with unknown result if they differ,
     #! otherwise retain them.
-    2dup = [ drop ] [ unify-classes <computed> ] ifte ;
+    2dup = [
+        drop
+    ] [
+        unify-classes <computed>
+    ] ifte ;
 
 : unify-stacks ( list -- stack )
     #! Replace differing literals in stacks with unknown
@@ -109,10 +109,23 @@ SYMBOL: inferring-base-case
 
 SYMBOL: cloned
 
+: assq* ( key alist -- [ key | value ] )
+    #! Looks up the key in an alist. Push the key/value pair.
+    #! Most of the time you want to use assq not assq*.
+    dup [
+        2dup car car eq? [ nip car ] [ cdr assq* ] ifte
+    ] [
+        2drop f
+    ] ifte ;
+
+: assq ( key alist -- value )
+    #! Looks up the key in an alist.
+    assq* dup [ cdr ] when ;
+
 : deep-clone ( vector -- vector )
     #! Clone a vector if it hasn't already been cloned in this
     #! with-deep-clone scope.
-    dup cloned get assoc dup [
+    dup cloned get assq dup [
         nip
     ] [
         drop vector-clone [ dup cloned [ acons ] change ] keep
@@ -120,7 +133,7 @@ SYMBOL: cloned
 
 : deep-clone-vector ( vector -- vector )
     #! Clone a vector of vectors.
-    [ ( deep-clone ) vector-clone ] vector-map ;
+    [ deep-clone ] vector-map ;
 
 : copy-inference ( -- )
     #! We avoid cloning the same object more than once in order
@@ -133,7 +146,7 @@ SYMBOL: cloned
 
 : infer-branch ( value -- namespace )
     <namespace> [
-        uncons [ unswons [ \ value-class set ] bind ] when*
+        uncons [ unswons set-value-class ] when*
         dup value-recursion recursive-state set
         copy-inference
         literal-value infer-quot
@@ -151,6 +164,45 @@ SYMBOL: cloned
     #! given one in the list.
     [ over eq? not ] subset nip car car value-recursion ;
 
+! FIXME this is really bad
+: old-effect ( [ in-types out-types ] -- [ in | out ] )
+    uncons car length >r length r> cons ;
+
+: foo>effect ( [ in-types out-types ] -- [ in | out ] )
+    [ effect old-effect ] bind ;
+
+: raise ( [ in | out ] -- [ in | out ] )
+    uncons 2dup min tuck - >r - r> cons ;
+
+: effect>foo ( [ in | out ] -- [ intypes outtypes ] )
+    <namespace> [
+        uncons
+        [ drop object <computed> ] vector-project meta-d set
+        [ drop object <computed> ] vector-project d-in set
+        { } meta-r set
+    ] extend ;
+
+: decompose ( first second -- solution )
+    #! Return a stack effect such that first*solution = second.
+    2dup 2car
+    2dup > [ "No solution to decomposition" throw ] when
+    swap - -rot 2cdr >r + r> cons raise effect>foo ;
+
+: set-base ( effect rstate -- )
+    #! Set the base case of the current word.
+    dup [
+        car cdr [
+            entry-effect get old-effect dup [ 0 | 0 ] = [
+                drop
+            ] [
+                swap foo>effect decompose
+            ] ifte
+            base-case cons@
+        ] bind
+    ] [
+        2drop
+    ] ifte ;
+
 : recursive-branch ( branch branchlist -- )
     [
         dupd dual-branch >r infer-branch r> set-base
@@ -158,6 +210,16 @@ SYMBOL: cloned
         [ 2drop ] when
     ] catch ;
 
+: no-base-case ( word -- )
+    word-name " does not have a base case." cat2 throw ;
+
+: get-base ( word rstate -- effect )
+    [ base-case get ] bind dup [
+        nip [ unify-effects effect ] with-scope
+    ] [
+        drop no-base-case
+    ] ifte ;
+
 : infer-base-case ( branchlist -- )
     [
         inferring-base-case on
@@ -194,6 +256,17 @@ SYMBOL: cloned
     #! parameter is a vector.
     (infer-branches)  dup unify-effects unify-dataflow ;
 
+: (with-block) ( label quot -- )
+    #! Call a quotation in a new namespace, and transfer
+    #! inference state from the outer scope.
+    swap >r [
+        dataflow-graph off
+        call
+        d-in get meta-d get meta-r get get-dataflow
+    ] with-scope
+    r> swap #label dataflow, [ node-label set ] bind
+    meta-r set meta-d set d-in set ;
+
 : static-branch? ( value -- )
     literal? inferring-base-case get not and ;
 
@@ -221,11 +294,11 @@ SYMBOL: cloned
     [ object general-list general-list ] ensure-d
     dataflow-drop, pop-d
     dataflow-drop, pop-d swap
-    peek-d static-branch? [
+!    peek-d static-branch? [
-        static-ifte
+!        static-ifte
-    ] [
+!    ] [
         dynamic-ifte
-    ] ifte ;
+    ( ] ifte ) ;
 
 \ ifte [ infer-ifte ] "infer" set-word-property
 

library/inference/inference.factor

@@ -39,6 +39,10 @@ USE: hashtables
 USE: generic
 USE: prettyprint
 
+! If this symbol is on, partial evalution of conditionals is
+! disabled.
+SYMBOL: inferring-base-case
+
 ! Word properties that affect inference:
 ! - infer-effect -- must be set. controls number of inputs
 ! expected, and number of outputs produced.
@@ -64,6 +68,7 @@ GENERIC: literal-value ( value -- obj )
 GENERIC: value= ( literal value -- ? )
 GENERIC: value-class ( value -- class )
 GENERIC: value-class-and ( class value -- )
+GENERIC: set-value-class ( class value -- )
 
 TRAITS: computed
 C: computed ( class -- value )
@@ -79,6 +84,8 @@ M: computed value-class ( value -- class )
     [ \ value-class get ] bind ;
 M: computed value-class-and ( class value -- )
     [ \ value-class [ class-and ] change ] bind ;
+M: computed set-value-class ( class value -- )
+    [ \ value-class set ] bind ;
 
 TRAITS: literal
 C: literal ( obj rstate -- value )
@@ -91,6 +98,8 @@ M: literal value-class ( value -- class )
     literal-value class ;
 M: literal value-class-and ( class value -- )
     value-class class-and drop ;
+M: literal set-value-class ( class value -- )
+    2drop ;
 
 : value-recursion ( value -- rstate )
     [ recursive-state get ] bind ;
@@ -98,7 +107,7 @@ M: literal value-class-and ( class value -- )
 : (ensure-types) ( typelist n stack -- )
     pick [
         3dup >r >r car r> r> vector-nth value-class-and
-        >r >r cdr r> succ r> (ensure-types)
+        >r >r cdr r> 1 + r> (ensure-types)
     ] [
         3drop
     ] ifte ;
@@ -131,9 +140,6 @@ M: literal value-class-and ( class value -- )
     d-in get [ value-class ] vector-map vector>list
     meta-d get [ value-class ] vector-map vector>list 2list ;
 
-: old-effect ( [ in-types out-types ] | [ in | out ] )
-    uncons car length >r length r> cons ;
-
 : <recursive-state> ( -- state )
     <namespace> [
         base-case off  effect entry-effect set
@@ -162,37 +168,6 @@ DEFER: apply-word
     #! quotations.
     [ apply-object ] each ;
 
-: raise ( [ in | out ] -- [ in | out ] )
-    uncons 2dup min tuck - >r - r> cons ;
-
-: new-effect ( [ in | out ] -- [ intypes outtypes ] )
-    uncons
-    swap [ drop object ] project
-    swap [ drop object ] project
-    2list ;
-
-: decompose ( first second -- solution )
-    #! Return a stack effect such that first*solution = second.
-    over [ [ ] [ ] ] = [
-        nip
-    ] [
-        swap old-effect swap old-effect
-        2dup 2car
-        2dup > [ "No solution to decomposition" throw ] when
-        swap - -rot 2cdr >r + r> cons raise new-effect
-    ] ifte ;
-
-: set-base ( [ in | out ] rstate -- )
-    #! Set the base case of the current word.
-    dup [
-        car cdr [
-            [ effect ] bind entry-effect get swap decompose
-            base-case set
-        ] bind
-    ] [
-        2drop
-    ] ifte ;
-
 : check-return ( -- )
     #! Raise an error if word leaves values on return stack.
     meta-r get vector-length 0 = [

library/inference/words.factor

@@ -78,27 +78,16 @@ USE: prettyprint
 : no-effect ( word -- )
     "Unknown stack effect: " swap word-name cat2 throw ;
 
-: with-recursive-state ( word label quot -- )
-    >r
-    <recursive-state> [ recursive-label set ] extend dupd cons
-    recursive-state cons@
-    r> call ;
-
-: (with-block) ( label quot -- )
-    #! Call a quotation in a new namespace, and transfer
-    #! inference state from the outer scope.
-    swap >r [
-        dataflow-graph off
-        call
-        d-in get meta-d get meta-r get get-dataflow
-    ] with-scope
-    r> swap #label dataflow, [ node-label set ] bind
-    meta-r set meta-d set d-in set ;
-
 : with-block ( word label quot -- )
     #! Execute a quotation with the word on the stack, and add
     #! its dataflow contribution to a new block node in the IR.
-    over [ with-recursive-state ] (with-block) ;
+    over [
+        >r
+        <recursive-state> [ recursive-label set ] extend
+        dupd cons
+        recursive-state cons@
+        r> call
+    ] (with-block) ;
 
 : inline-compound ( word -- effect )
     #! Infer the stack effect of a compound word in the current
@@ -131,9 +120,6 @@ M: symbol (apply-word) ( word -- )
     #! Push word we're currently inferring effect of.
     recursive-state get car car ;
 
-: no-base-case ( word -- )
-    word-name " does not have a base case." cat2 throw ;
-
 : check-recursion ( -- )
     #! If at the location of the recursive call, we're taking
     #! more items from the stack than producing, we have a
@@ -147,32 +133,25 @@ M: symbol (apply-word) ( word -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive
     #! call is to a local block, emit a label call node.
-    base-case over hash dup [
+    [ get-base ] 2keep [ recursive-label get ] bind
-        swap [ recursive-label get ] bind ( word effect label )
     dup [
-            rot drop #call-label rot
+        ( word effect label )
+        nip #call-label
     ] [
-            drop #call swap
+        drop #call
-        ] ifte (consume/produce)
+    ] ifte rot (consume/produce) ;
-    ] [
-        2drop no-base-case
-    ] ifte ;
 
 : apply-word ( word -- )
     #! Apply the word's stack effect to the inferencer state.
-    dup recursive-state get assoc dup [
+    dup recursive-state get assoc [
         check-recursion recursive-word
     ] [
-        drop dup "infer-effect" word-property dup [
+        dup "infer-effect" word-property [
             apply-effect
-        ] [
-            drop dup "no-effect" word-property [
-                no-effect
         ] [
             (apply-word)
-            ] ifte
+        ] ifte*
-        ] ifte
+    ] ifte* ;
-    ] ifte ;
 
 : infer-call ( -- )
     [ general-list ] ensure-d

library/io/ansi.factor

@@ -91,4 +91,7 @@ C: ansi-stream ( stream -- stream )
     #! ansi-bg - background color
     [ delegate set ] extend ;
 
-global [ [ <ansi-stream> ] smart-term-hook set ] bind
+IN: shells
+
+: ansi
+    stdio [ <ansi-stream> ] change tty ;

library/io/stdio.factor

@@ -77,6 +77,3 @@ C: stdio-stream ( delegate -- stream )
     swap stdio get <prefix-stream> [
         stdio set call
     ] with-scope ; inline
-
-! Set this to a quotation in init code, depending on OS.
-SYMBOL: smart-term-hook

library/io/stream.factor

@@ -48,7 +48,9 @@ GENERIC: fclose      ( stream -- )
     f swap fwrite-attr ;
 
 : fprint ( string stream -- )
-    tuck fwrite "\n" over fwrite fauto-flush ;
+    [ fwrite ] keep
+    [ "\n" swap fwrite ] keep
+    fauto-flush ;
 
 TRAITS: string-output-stream
 

library/io/win32-console.factor

@@ -85,5 +85,5 @@ M: win32-console-stream fwrite-attr ( string style stream -- )
 C: win32-console-stream ( stream -- stream )
     [ -11 GetStdHandle handle set delegate set ] extend ;
 
-global [ [ <win32-console-stream> ] smart-term-hook set ] bind
+! global [ [ <win32-console-stream> ] smart-term-hook set ] bind
 

library/lists.factor

@@ -126,7 +126,7 @@ DEFER: tree-contains?
     [ dupd = not ] subset nip ;
 
 : length ( list -- length )
-    0 swap [ drop succ ] each ;
+    0 swap [ drop 1 + ] each ;
 
 : prune ( list -- list )
     #! Remove duplicate elements.
@@ -168,7 +168,7 @@ M: cons = ( obj cons -- ? )
         2drop 0
     ] [
         over cons? [
-            pred >r uncons r> tuck
+            1 - >r uncons r> tuck
             cons-hashcode >r
             cons-hashcode r>
             bitxor
@@ -191,7 +191,7 @@ M: cons hashcode ( cons -- hash ) 4 cons-hashcode ;
 
 : head ( list n -- list )
     #! Return the first n elements of the list.
-    dup 0 > [ >r uncons r> pred head cons ] [ 2drop f ] ifte ;
+    dup 0 > [ >r uncons r> 1 - head cons ] [ 2drop f ] ifte ;
 
 : tail ( list n -- tail )
     #! Return the rest of the list, from the nth index onward.

library/math/arc-trig-hyp.factor

@@ -36,11 +36,11 @@ USE: math-internals
 ! Inverse hyperbolic functions:
 !    acosh asech asinh acosech atanh acoth
 
-: acosh dup sq pred sqrt + log ;
+: acosh dup sq 1 - sqrt + log ;
 : asech recip acosh ;
-: asinh dup sq succ sqrt + log ;
+: asinh dup sq 1 + sqrt + log ;
 : acosech recip asinh ;
-: atanh dup succ swap pred neg / log 2 / ;
+: atanh dup 1 + swap 1 - neg / log 2 / ;
 : acoth recip atanh ;
 : <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ;
 : asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ;

library/math/math-combinators.factor

@@ -33,14 +33,14 @@ USE: kernel
     #!
     #! In order to compile, the code must produce as many values
     #! as it consumes.
-    tuck >r dup 0 <= [ r> 3drop ] [ pred slip r> times ] ifte ;
+    tuck >r dup 0 <= [ r> 3drop ] [ 1 - slip r> times ] ifte ;
     inline
 
 : (times) ( limit n quot -- )
     pick pick <= [
         3drop
     ] [
-        rot pick succ pick 3slip (times)
+        rot pick 1 + pick 3slip (times)
     ] ifte ; inline
 
 : times* ( n quot -- )
@@ -52,15 +52,15 @@ USE: kernel
     0 swap (times) ; inline
 
 : fac ( n -- n! )
-    1 swap [ succ * ] times* ;
+    1 swap [ 1 + * ] times* ;
 
 : 2times-succ ( #{ a b } #{ c d } -- z )
     #! Lexicographically add #{ 0 1 } to a complex number.
     #! If d + 1 == b, return #{ c+1 0 }. Otherwise, #{ c d+1 }.
-    2dup imaginary succ swap imaginary = [
+    2dup imaginary 1 + swap imaginary = [
-        nip real succ
+        nip real 1 +
     ] [
-        nip >rect succ rect>
+        nip >rect 1 + rect>
     ] ifte ; inline
 
 : 2times<= ( #{ a b } #{ c d } -- ? )
@@ -77,3 +77,15 @@ USE: kernel
     #! Apply a quotation to each pair of complex numbers
     #! #{ a b } such that a < w, b < h.
     0 swap (2times) ; inline
+
+: (repeat) ( i n quot -- )
+    pick pick >= [
+        3drop
+    ] [
+        [ swap >r call 1 + r> ] keep (repeat)
+    ] ifte ;
+
+: repeat ( n quot -- )
+    #! Execute a quotation n times. The loop counter is kept on
+    #! the stack, and ranges from 0 to n-1.
+    0 -rot (repeat) ;

library/math/math.factor

@@ -87,9 +87,6 @@ M: number = ( n n -- ? ) number= ;
 
 : sq dup * ; inline
 
-: pred 1 - ; inline
-: succ 1 + ; inline
-
 : neg 0 swap - ; inline
 : recip 1 swap / ; inline
 

library/namespaces.factor

@@ -30,6 +30,7 @@ USE: hashtables
 USE: kernel
 USE: kernel-internals
 USE: lists
+USE: vectors
 
 ! Other languages have classes, objects, variables, etc.
 ! Factor has similar concepts.
@@ -50,8 +51,8 @@ USE: lists
 ! bind ( namespace quot -- ) executes a quotation with a
 ! namespace pushed on the namespace stack.
 
-: namestack ( -- ns ) 3 getenv ;
+: namestack ( -- ns ) 3 getenv ; inline
-: set-namestack ( ns -- ) 3 setenv ;
+: set-namestack ( ns -- ) 3 setenv ; inline
 
 : namespace ( -- namespace )
     #! Push the current namespace.
@@ -59,7 +60,7 @@ USE: lists
 
 : >n ( namespace -- n:namespace )
     #! Push a namespace on the namespace stack.
-    namestack cons set-namestack ; inline
+    >vector namestack cons set-namestack ; inline
 
 : n> ( n:namespace -- namespace )
     #! Pop the top of the namespace stack.

library/primitives.factor

@@ -98,7 +98,7 @@ USE: words
     [ fixnum<=               " x y -- ? "                         [ [ fixnum fixnum ] [ boolean ] ] ]
     [ fixnum>                " x y -- ? "                         [ [ fixnum fixnum ] [ boolean ] ] ]
     [ fixnum>=               " x y -- ? "                         [ [ fixnum fixnum ] [ boolean ] ] ]
-    [ bignum=                " x y -- ? "                         [ [ fixnum fixnum ] [ boolean ] ] ]
+    [ bignum=                " x y -- ? "                         [ [ bignum bignum ] [ boolean ] ] ]
     [ bignum+                " x y -- x+y "                       [ [ bignum bignum ] [ bignum ] ] ]
     [ bignum-                " x y -- x-y "                       [ [ bignum bignum ] [ bignum ] ] ]
     [ bignum*                " x y -- x*y "                       [ [ bignum bignum ] [ bignum ] ] ]

library/random.factor

@@ -34,14 +34,14 @@ USE: math
     dup dup neg bitand = ;
 
 : (random-int-0) ( n bits val -- n )
-    3dup - + pred 0 < [
+    3dup - + 1 < [
         2drop (random-int) 2dup swap mod (random-int-0)
     ] [
         nip nip
     ] ifte ;
 
 : random-int-0 ( max -- n )
-    succ dup power-of-2? [
+    1 + dup power-of-2? [
         (random-int) * -31 shift
     ] [
         (random-int) 2dup swap mod (random-int-0)

library/sdl/console.factor

@@ -111,7 +111,7 @@ SYMBOL: line-editor
 
 : add-line ( text -- )
     lines get vector-push
-    lines get vector-length succ first-line get - visible-lines -
+    lines get vector-length 1 + first-line get - visible-lines -
     dup 0 >= [
         first-line [ + ] change
     ] [
@@ -198,7 +198,7 @@ M: backspace-key key-down ( key -- )
     line-editor get dup sbuf-length 0 = [
         drop
     ] [
-        [ sbuf-length pred ] keep set-sbuf-length
+        [ sbuf-length 1 - ] keep set-sbuf-length
     ] ifte ;
 
 M: integer key-down ( key -- )
@@ -250,7 +250,9 @@ M: alien handle-event ( event -- ? )
 
 SYMBOL: escape-continuation
 
-: start-console ( -- )
+IN: shells
+
+: sdl ( -- )
     <namespace> [
         800 600 32 SDL_HWSURFACE init-screen
         init-console

library/sdl/hsv.factor

@@ -14,9 +14,9 @@ USE: namespaces
 USE: vectors
 
 : f_ ( h s v i -- f ) >r swap rot >r 2dup r> 6 * r> - ;
-: p ( v s x -- v p x ) >r dupd neg succ * r> ;
+: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
-: q ( v s f -- q ) * neg succ * ;
+: q ( v s f -- q ) * neg 1 + * ;
-: t_ ( v s f -- t_ ) neg succ * neg succ * ;
+: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
 
 : mod-cond ( p vector -- )
     #! Call p mod q'th entry of the vector of quotations, where

library/strings.factor

@@ -96,7 +96,7 @@ UNION: text string integer ;
     #! Returns 2 strings, that when concatenated yield the
     #! original string, without the character at the given
     #! index.
-    [ swap str-head ] 2keep succ swap str-tail ;
+    [ swap str-head ] 2keep 1 + swap str-tail ;
 
 : str-head? ( str begin -- ? )
     2dup str-length< [

library/syntax/parse-stream.factor

@@ -42,7 +42,7 @@ USE: strings
 
 : next-line ( -- str )
     "parse-stream" get freadln
-    "line-number" [ succ ] change ;
+    "line-number" [ 1 + ] change ;
 
 : (read-lines) ( quot -- )
     next-line dup [

library/syntax/parser.factor

@@ -66,7 +66,7 @@ USE: unparser
     "line" off "col" off ;
 
 : ch ( -- ch ) "col" get "line" get str-nth ;
-: advance ( -- ) "col" [ succ ] change ;
+: advance ( -- ) "col" [ 1 + ] change ;
 
 : skip ( n line quot -- n )
     #! Find the next character that satisfies the quotation,
@@ -75,7 +75,7 @@ USE: unparser
         2dup str-nth r> dup >r call [
             r> 2drop
         ] [
-            >r succ r> r> skip
+            >r 1 + r> r> skip
         ] ifte
     ] [
         r> drop nip str-length
@@ -101,7 +101,7 @@ USE: unparser
     dup >r skip-blank dup r>
     2dup str-length < [
         2dup str-nth denotation? [
-            drop succ
+            drop 1 +
         ] [
             skip-word
         ] ifte
@@ -159,7 +159,7 @@ USE: unparser
     "col" get "line" get rot index-of* ;
 
 : (until) ( index -- str )
-    "col" get swap dup succ "col" set "line" get substring ;
+    "col" get swap dup 1 + "col" set "line" get substring ;
 
 : until ( ch -- str )
     ch-search (until) ;

library/syntax/prettyprint.factor

@@ -40,6 +40,8 @@ USE: vectors
 USE: words
 USE: hashtables
 
+SYMBOL: prettyprint-limit
+
 GENERIC: prettyprint* ( indent obj -- indent )
 
 M: object prettyprint* ( indent obj -- indent )
@@ -49,10 +51,6 @@ M: object prettyprint* ( indent obj -- indent )
     #! Change this to suit your tastes.
     4 ;
 
-: prettyprint-limit ( -- limit )
-    #! Avoid infinite loops -- maximum indent, 10 levels.
-    "prettyprint-limit" get [ 40 ] unless* ;
-
 : indent ( indent -- )
     #! Print the given number of spaces.
     " " fill write ;
@@ -64,7 +62,7 @@ M: object prettyprint* ( indent obj -- indent )
     " " write ;
 
 : prettyprint-element ( indent obj -- indent )
-    over prettyprint-limit >= [
+    over prettyprint-limit get >= [
         unparse write
     ] [
         prettyprint*
@@ -186,7 +184,7 @@ M: hashtable prettyprint* ( indent hashtable -- indent )
 : . ( obj -- )
     [
         "prettyprint-single-line" on
-        tab-size 4 * "prettyprint-limit" set
+        16 prettyprint-limit set
         prettyprint
     ] with-scope ;
 
@@ -207,3 +205,5 @@ M: hashtable prettyprint* ( indent hashtable -- indent )
 : .b >bin print ;
 : .o >oct print ;
 : .h >hex print ;
+
+global [ 40 prettyprint-limit set ] bind

library/syntax/see.factor

@@ -37,15 +37,24 @@ USE: unparser
 USE: words
 
 ! Prettyprinting words
-: vocab-attrs ( word -- attrs )
+: vocab-actions ( search -- list )
-    vocab-link "object-link" default-style acons ;
+    [
+        [ "Words"   | "words."        ]
+        [ "Use"     | "\"use\" cons@" ]
+        [ "In"      | "\"in\" set" ]
+    ] ;
+
+: vocab-attrs ( vocab -- attrs )
+    #! Words without a vocabulary do not get a link or an action
+    #! popup.
+    unparse vocab-actions <actions> "actions" swons unit ;
 
 : prettyprint-vocab ( vocab -- )
     dup vocab-attrs write-attr ;
 
-: prettyprint-IN: ( indent word -- )
+: prettyprint-IN: ( word -- )
     \ IN: prettyprint* prettyprint-space
-    word-vocabulary prettyprint-vocab prettyprint-newline ;
+    word-vocabulary prettyprint-vocab prettyprint-space ;
 
 : prettyprint-: ( indent -- indent )
     \ : prettyprint* prettyprint-space
@@ -95,19 +104,22 @@ M: object see ( obj -- )
     "Not a word: " write . ;
 
 M: compound see ( word -- )
-    0 swap
+    [ prettyprint-IN: ] keep
-    [ dupd prettyprint-IN: prettyprint-: ] keep
+    0 prettyprint-: swap
     [ prettyprint-1 ] keep
     [ prettyprint-docs ] keep
     [ word-parameter prettyprint-list prettyprint-; ] keep
     prettyprint-plist prettyprint-newline ;
 
 M: primitive see ( word -- )
-    "PRIMITIVE: " write dup unparse write stack-effect. terpri ;
+    dup prettyprint-IN:
+    "PRIMITIVE: " write dup prettyprint-1 stack-effect. terpri ;
 
 M: symbol see ( word -- )
-    0 over prettyprint-IN:
+    dup prettyprint-IN:
+    0 swap
     \ SYMBOL: prettyprint-1 prettyprint-space . ;
 
 M: undefined see ( word -- )
-    drop "Not defined" print ;
+    dup prettyprint-IN:
+    \ DEFER: prettyprint-1 prettyprint-space . ;

library/syntax/unparser.factor

@@ -41,7 +41,7 @@ GENERIC: unparse ( obj -- str )
 M: object unparse ( obj -- str )
     [
         "#<" ,
-        dup type type-name ,
+        dup class unparse ,
         " @ " , 
         address unparse ,
         ">" ,
@@ -51,10 +51,10 @@ M: object unparse ( obj -- str )
     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
 
 : integer, ( num radix -- )
-    tuck /mod >digit , dup 0 > [
+    dup >r /mod >digit , dup 0 > [
-        swap integer,
+        r> integer,
     ] [
-        2drop
+        r> 2drop
     ] ifte ;
 
 : >base ( num radix -- string )

library/test/benchmark/ack.factor

@@ -7,12 +7,12 @@ USE: test
 
 : ack ( m n -- x )
     over 0 = [
-        nip succ
+        nip 1 +
     ] [
         dup 0 = [
-            drop pred 1 ack
+            drop 1 - 1 ack
         ] [
-            dupd pred ack >r pred r> ack
+            dupd 1 - ack >r 1 - r> ack
         ] ifte
     ] ifte ; compiled
 

library/test/benchmark/fac.factor

@@ -4,6 +4,6 @@ USE: test
 USE: compiler
 
 : fac-benchmark
-    10000 fac 10000 [ succ / ] times* ; compiled
+    10000 fac 10000 [ 1 + / ] times* ; compiled
 
 [ 1 ] [ fac-benchmark ] unit-test

library/test/benchmark/fib.factor

@@ -5,7 +5,7 @@ USE: math
 USE: test
 
 : fib ( n -- nth fibonacci number )
-    dup 1 <= [ drop 1 ] [ pred dup fib swap pred fib + ] ifte ;
+    dup 1 <= [ drop 1 ] [ 1 - dup fib swap 1 - fib + ] ifte ;
     compiled
 
 [ 9227465 ] [ 34 fib ] unit-test

library/test/benchmark/strings.factor

@@ -11,7 +11,7 @@ USE: compiler
     2dup str-length > [
         dup [ "123" , , "456" , , "789" , ] make-string
         dup dup str-length 2 /i 0 swap rot substring
-        swap dup str-length 2 /i succ 1 swap rot substring cat2
+        swap dup str-length 2 /i 1 + 1 swap rot substring cat2
         string-step
     ] [
         2drop

library/test/continuations.factor

@@ -9,7 +9,7 @@ USE: test
 : callcc1-test ( x -- list )
     [
         "test-cc" set [ ] [
-            swap pred tuck swons
+            swap 1 - tuck swons
             over 0 = [ "test-cc" get call ] when
         ] forever
     ] callcc1 nip ;

library/test/dataflow.factor

@@ -79,7 +79,7 @@ SYMBOL: #test
     {{
         [ node-op | #test ]
         [ node-param | 5 ]
-    }} "foobar" [ [ node-param get ] bind succ ] apply-dataflow
+    }} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow
 ] unit-test
 
 #test [ [ node-param get ] bind sq ] "foobar" set-word-property
@@ -88,7 +88,7 @@ SYMBOL: #test
     {{
         [ node-op | #test ]
         [ node-param | 5 ]
-    }} "foobar" [ [ node-param get ] bind succ ] apply-dataflow
+    }} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow
 ] unit-test
 
 ! Somebody (cough) got the order of ifte nodes wrong.

library/test/inference.factor

@@ -215,11 +215,11 @@ SYMBOL: sym-test
 
 ! Type inference
 
-[ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
+! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
-[ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
+! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
-[ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
+! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
-[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
+! [ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
-[ [ [ object ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
+! [ [ [ object ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
 ! [ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
 ! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
 ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test

library/test/strings.factor

@@ -83,7 +83,7 @@ unit-test
 
 [ 4 ] [
     0 "There are Four Upper Case characters"
-    [ LETTER? [ succ ] when ] str-each
+    [ LETTER? [ 1 + ] when ] str-each
 ] unit-test
 
 [ "Replacing+spaces+with+plus" ]

library/test/test.factor

@@ -55,7 +55,7 @@ USE: unparser
 
 : test ( name -- )
     ! Run the given test.
-    depth pred >r
+    depth 1 - >r
     "Testing " write dup write "..." print
     "/library/test/" swap ".factor" cat3 run-resource
     "Checking before/after depth..." print

library/tools/debugger.factor

@@ -63,7 +63,7 @@ USE: generic
     "Type check error" print
     uncons car dup "Object: " write .
     "Object type: " write class .
-    "Expected type: " write type-name print ;
+    "Expected type: " write builtin-type . ;
 
 : range-error ( list -- )
     "Range check error" print

library/tools/heap-stats.factor

@@ -48,4 +48,4 @@ USE: generic
 
 : heap-stats. ( -- )
     #! Print heap allocation breakdown.
-    0 heap-stats [ dupd uncons heap-stat. succ ] each drop ;
+    0 heap-stats [ dupd uncons heap-stat. 1 + ] each drop ;

library/tools/listener.factor

@@ -38,6 +38,7 @@ USE: presentation
 USE: words
 USE: unparser
 USE: vectors
+USE: ansi
 
 SYMBOL: cont-prompt
 SYMBOL: listener-prompt
@@ -143,3 +144,8 @@ global [
     terpri
     "HTTP SERVER:             USE: httpd 8888 httpd" print
     "TELNET SERVER:           USE: telnetd 9999 telnetd" print ;
+
+IN: shells
+
+: tty
+    print-banner listener ;

library/tools/telnetd.factor

@@ -34,6 +34,7 @@ USE: namespaces
 USE: stdio
 USE: streams
 USE: threads
+USE: parser
 
 : telnet-client ( socket -- )
     dup [
@@ -52,3 +53,10 @@ USE: threads
     [
         <server> [ telnetd-loop ] [ swap fclose rethrow ] catch
     ] with-logging ;
+
+IN: shells
+
+: telnet
+    "telnetd-port" get str>number telnetd ;
+
+global [ 9999 "telnetd-port" set ] bind

library/vectors.factor

@@ -75,11 +75,11 @@ BUILTIN: vector 11
 
 : vector-peek ( vector -- obj )
     #! Get value at end of vector.
-    dup vector-length pred swap vector-nth ;
+    dup vector-length 1 - swap vector-nth ;
 
 : vector-pop ( vector -- obj )
     #! Get value at end of vector and remove it.
-    dup vector-length pred ( vector top )
+    dup vector-length 1 - ( vector top )
     2dup swap vector-nth >r swap set-vector-length r> ;
 
 : >pop> ( stack -- stack )

native/signal.h

@@ -1,5 +1,6 @@
 #ifndef WIN32
 void signal_handler(int signal, siginfo_t* siginfo, void* uap);
+void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
 void call_profiling_step(int signal, siginfo_t* siginfo, void* uap);
 void init_signals(void);
 #endif

native/stack.c

@@ -15,11 +15,17 @@ void fix_stacks(void)
 	if(STACK_UNDERFLOW(ds,ds_bot))
 		reset_datastack();
 	else if(STACK_OVERFLOW(ds,ds_bot))
+	{
+		fprintf(stderr,"ds oveflow\n");
 		reset_datastack();
+	}
 	else if(STACK_UNDERFLOW(cs,cs_bot))
 		reset_callstack();
 	else if(STACK_OVERFLOW(cs,cs_bot))
+	{
+		fprintf(stderr,"cs oveflow\n");
 		reset_callstack();
+	}
 }
 
 void init_stacks(void)

native/unix/signal.c

@@ -15,6 +15,11 @@ void signal_handler(int signal, siginfo_t* siginfo, void* uap)
 		signal_error(signal);
 }
 
+void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap)
+{
+	dump_stacks();
+}
+
 /* Called from a signal handler. XXX - is this safe? */
 void call_profiling_step(int signal, siginfo_t* siginfo, void* uap)
 {
@@ -36,10 +41,13 @@ void init_signals(void)
 	struct sigaction custom_sigaction;
 	struct sigaction profiling_sigaction;
 	struct sigaction ign_sigaction;
+	struct sigaction dump_sigaction;
 	custom_sigaction.sa_sigaction = signal_handler;
 	custom_sigaction.sa_flags = SA_SIGINFO;
 	profiling_sigaction.sa_sigaction = call_profiling_step;
 	profiling_sigaction.sa_flags = SA_SIGINFO;
+	dump_sigaction.sa_sigaction = dump_stack_signal;
+	dump_sigaction.sa_flags = SA_SIGINFO;
 	ign_sigaction.sa_handler = SIG_IGN;
 	sigaction(SIGABRT,&custom_sigaction,NULL);
 	sigaction(SIGFPE,&custom_sigaction,NULL);
@@ -47,6 +55,7 @@ void init_signals(void)
 	sigaction(SIGSEGV,&custom_sigaction,NULL);
 	sigaction(SIGPIPE,&ign_sigaction,NULL);
 	sigaction(SIGPROF,&profiling_sigaction,NULL);
+	sigaction(SIGQUIT,&dump_sigaction,NULL);
 }
 
 void primitive_call_profiling(void)