fix literal dataflow, other fixes

TODO.FACTOR.txt

@@ -52,7 +52,7 @@
 - jedit ==> jedit-word, jedit takes a file name
 - command line parsing cleanup
 - nicer way to combine two paths
-- OOP
+- finish OOP
 - ditch object paths
 - browser responder for word links in HTTPd; inspect responder for
   objects

library/bootstrap/boot-stage2.factor

@@ -63,7 +63,6 @@ USE: stdio
     "/library/io/io-internals.factor"
     "/library/io/stream-impl.factor"
     "/library/io/stdio.factor"
-    "/library/io/extend-stream.factor"
     "/library/words.factor"
     "/library/vocabularies.factor"
     "/library/syntax/parse-numbers.factor"

library/bootstrap/boot.factor

@@ -64,7 +64,6 @@ primitives,
     "/library/io/io-internals.factor"
     "/library/io/stream-impl.factor"
     "/library/io/stdio.factor"
-    "/library/io/extend-stream.factor"
     "/library/words.factor"
     "/library/vocabularies.factor"
     "/library/syntax/parse-numbers.factor"
@@ -83,5 +82,6 @@ DEFER: boot
 [
     boot
     "Good morning!" print
+    flush
     "/library/bootstrap/boot-stage2.factor" run-resource
 ] boot-quot set

library/bootstrap/cross-compiler.factor

@@ -405,6 +405,6 @@ IN: image
 : cross-compile-resource ( resource -- )
     [
         ! Change behavior of ; and SYMBOL:
-        [ pick USE: prettyprint . define, ] "define-hook" set
+        [ define, ] "define-hook" set
         run-resource
     ] with-scope ;

library/bootstrap/image.factor

@@ -180,10 +180,10 @@ SYMBOL: boot-quot
 
 ( Words )
 
-: word, ( -- pointer )
+: word, ( word -- pointer )
-    word-tag here-as word-tag >header emit
+    word-tag here-as >r word-tag >header emit
-    0 HEX: fffffff random-int emit ( hashcode )
+    hashcode emit ( hashcode )
-    0 emit ;
+    0 emit r> ;
 
 ! This is to handle mutually recursive words
 
@@ -272,7 +272,7 @@ DEFER: '
 : define, ( word primitive parameter -- )
     #! Write a word definition to the image.
     ' >r >r dup (word+) dup emit-plist >r
-    word, pool-object
+    dup word, pool-object
     r> ( -- plist )
     r> ( primitive -- ) emit
     r> ( parameter -- ) emit

library/bootstrap/init-stage2.factor

@@ -83,9 +83,9 @@ init-error-handler
 
 0 [ drop succ ] each-word unparse write " words" print 
 
-! "Inferring stack effects..." print
+"Inferring stack effects..." print
-! 0 [ unit try-infer [ succ ] when ] each-word
+0 [ unit try-infer [ succ ] when ] each-word
-! unparse write " words have a stack effect" print
+unparse write " words have a stack effect" print
 
 "Bootstrapping is complete." print
 "Now, you can run ./f factor.image" print

library/generic.factor

@@ -65,15 +65,17 @@ SYMBOL: delegate
 : no-method
     "No applicable method." throw ;
 
-: method ( selector traits -- quot )
+: method ( selector traits -- traits quot )
     #! Look up the method with the traits object on the stack.
+    #! Returns the traits to call the method on; either the
+    #! original object, or one of the delegates.
     2dup object-map hash* dup [
-        nip nip cdr ( method is defined )
+        rot drop cdr ( method is defined )
     ] [
         drop delegate swap hash* dup [
             cdr method ( check delegate )
         ] [
-            3drop [ no-method ] ( no delegate )
+            drop [ no-method ] ( no delegate )
         ] ifte
     ] ifte ;
 
@@ -100,7 +102,7 @@ SYMBOL: delegate
     #! bar method on the traits object, with the traits object
     #! on the stack.
     CREATE
-    dup unit [ car over method call ] cons
+    dup unit [ car swap method call ] cons
     define-compound ; parsing
 
 : constructor-word ( word -- word )

library/httpd/html.factor

@@ -38,6 +38,8 @@ USE: streams
 USE: strings
 USE: unparser
 USE: url-encoding
+USE: presentation
+USE: generic
 
 : html-entities ( -- alist )
     [
@@ -133,16 +135,20 @@ USE: url-encoding
         drop call
     ] ifte ;
 
-: html-write-attr ( string style -- )
+TRAITS: html-stream
+
+M: html-stream fwrite-attr ( str style stream -- )
     [
         [
             [
-                [ drop chars>entities write ] span-tag
+                [
-            ] file-link-tag
+                    [ drop chars>entities write ] span-tag
-        ] object-link-tag
+                ] file-link-tag
-    ] icon-tag ;
+            ] object-link-tag
+        ] icon-tag
+    ] bind ;M
 
-: <html-stream> ( stream -- stream )
+C: html-stream ( stream -- stream )
     #! Wraps the given stream in an HTML stream. An HTML stream
     #! converts special characters to entities when being
     #! written, and supports writing attributed strings with
@@ -156,11 +162,7 @@ USE: url-encoding
     #! underline
     #! size
     #! link - an object path
-    <extend-stream> [
+    [ dup delegate set "stdio" set ] extend ;
-        [ chars>entities write ] "fwrite" set
-        [ chars>entities print ] "fprint" set
-        [ html-write-attr ] "fwrite-attr" set
-    ] extend ;
 
 : with-html-stream ( quot -- )
     [ "stdio" get <html-stream> "stdio" set call ] with-scope ;

library/inference/branches.factor

@@ -111,8 +111,8 @@ USE: hashtables
 : infer-ifte ( -- )
     #! Infer effects for both branches, unify.
     3 ensure-d
-    \ drop CALL dataflow, drop pop-d
+    dataflow-drop, pop-d
-    \ drop CALL dataflow, drop pop-d 2list
+    dataflow-drop, pop-d 2list
     IFTE
     pop-d drop ( condition )
     infer-branches ;
@@ -128,7 +128,7 @@ USE: hashtables
 : infer-generic ( -- )
     #! Infer effects for all branches, unify.
     2 ensure-d
-    \ drop CALL dataflow, drop pop-d vtable>list
+    dataflow-drop, pop-d vtable>list
     GENERIC
     peek-d drop ( dispatch )
     infer-branches ;
@@ -136,7 +136,7 @@ USE: hashtables
 : infer-2generic ( -- )
     #! Infer effects for all branches, unify.
     3 ensure-d
-    \ drop CALL dataflow, drop pop-d vtable>list
+    dataflow-drop, pop-d vtable>list
     2GENERIC
     peek-d drop ( dispatch )
     peek-d drop ( dispatch )

library/inference/dataflow.factor

@@ -89,3 +89,8 @@ SYMBOL: node-param
 : dataflow, ( param op -- node )
     #! Add a node to the dataflow IR.
     <dataflow-node> dup dataflow-graph cons@ ;
+
+: dataflow-drop, ( -- )
+    #! Remove the top stack element and add a dataflow node
+    #! noting this.
+    \ drop CALL dataflow, [ 1 0 node-inputs ] bind ;

library/inference/inference.factor

@@ -109,7 +109,8 @@ DEFER: apply-word
 : apply-literal ( obj -- )
     #! Literals are annotated with the current recursive
     #! state.
-    dup PUSH dataflow, drop  recursive-state get cons push-d ;
+    dup recursive-state get cons push-d
+    PUSH dataflow, [ 1 0 node-outputs ] bind ;
 
 : apply-object ( obj -- )
     #! Apply the object's stack effect to the inferencer state.

library/inference/stack.factor

@@ -31,6 +31,19 @@ USE: interpreter
 USE: stack
 USE: words
 USE: lists
+USE: namespaces
+
+\ >r [
+    \ >r CALL dataflow, [ 1 0 node-inputs ] extend
+    pop-d push-r
+    [ 0 1 node-outputs ] bind
+] "infer" set-word-property
+
+\ r> [
+    \ r> CALL dataflow, [ 0 1 node-inputs ] extend
+    pop-r push-d
+    [ 1 0 node-outputs ] bind
+] "infer" set-word-property
 
 : meta-infer ( word -- )
     #! Mark a word as being partially evaluated.
@@ -41,13 +54,6 @@ USE: lists
        \ with-dataflow ,
     ] make-list "infer" set-word-property ;
 
-\ >r [
-    \ >r CALL dataflow, drop pop-d push-r
-] "infer" set-word-property
-\ r> [
-    \ r> CALL dataflow, drop pop-r push-d
-] "infer" set-word-property
-
 \ drop meta-infer
 \ dup meta-infer
 \ swap meta-infer

library/io/ansi.factor

@@ -35,6 +35,8 @@ USE: stack
 USE: stdio
 USE: streams
 USE: strings
+USE: presentation
+USE: generic
 
 ! Some words for outputting ANSI colors.
 
@@ -76,13 +78,18 @@ USE: strings
 : ansi-attr-string ( string style -- string )
     [ ansi-attrs , reset , ] make-string ;
 
-: <ansi-stream> ( stream -- stream )
+TRAITS: ansi-stream
+
+M: ansi-stream fwrite-attr ( string style stream -- )
+    [
+        [ default-style ] unless* ansi-attr-string
+        delegate get fwrite
+    ] bind ;M
+
+C: ansi-stream ( stream -- stream )
     #! Wraps the given stream in an ANSI stream. ANSI streams
     #! support the following character attributes:
     #! bold    - if not f, text is boldface.
     #! ansi-fg - foreground color
     #! ansi-bg - background color
-    <extend-stream> [
+    [ delegate set ] extend ;
-        ( string style -- )
-        [ ansi-attr-string write ] "fwrite-attr" set
-    ] extend ;

library/io/extend-stream.factor

@@ -1,57 +0,0 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-! 
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: streams
-USE: errors
-USE: kernel
-USE: namespaces
-USE: stack
-USE: stdio
-USE: strings
-
-: <extend-stream> ( stream -- stream )
-    #! Create a stream that wraps another stream. Override some
-    #! or all of the stream words.
-    <stream> [
-        "stdio" set
-        ( -- string )
-        [ read ] "freadln" set
-        ( -- string )
-        [ read1 ] "fread1" set
-        ( count -- string )
-        [ read# ] "fread#" set
-        ( string -- )
-        [ write ] "fwrite" set
-        ( string style -- )
-        [ write-attr ] "fwrite-attr" set
-        ( -- )
-        [ flush ] "fflush" set
-        ( -- )
-        [ "stdio" get fclose ] "fclose" set
-        ( string -- )
-        [ print ] "fprint" set
-    ] extend ;

library/io/network.factor

@@ -38,17 +38,18 @@ USE: stdio
 USE: strings
 USE: namespaces
 USE: unparser
+USE: generic
 
-: <server> ( port -- stream )
+TRAITS: server
+
+M: server fclose ( stream -- )
+    [ "socket" get close-port ] bind ;M
+
+C: server ( port -- stream )
     #! Starts listening on localhost:port. Returns a stream that
     #! you can close with fclose, and accept connections from
     #! with accept. No other stream operations are supported.
-    server-socket <stream> [
+    [ server-socket "socket" set ] extend ;C
-        "socket" set
-
-        ( -- )
-        [ "socket" get close-port ] "fclose" set
-    ] extend ;
 
 : <client-stream> ( host port in out -- stream )
     <fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;

library/io/stdio.factor

@@ -25,9 +25,6 @@
 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-IN: streams
-DEFER: <extend-stream>
-
 IN: stdio
 USE: combinators
 USE: errors
@@ -36,40 +33,23 @@ USE: lists
 USE: namespaces
 USE: stack
 USE: streams
+USE: generic
+USE: strings
 
-: flush ( -- )
+: flush      ( -- )              "stdio" get fflush ;
-    "stdio" get fflush ;
+: read       ( -- string )       "stdio" get freadln ;
-
+: read1      ( count -- string ) "stdio" get fread1 ;
-: read ( -- string )
+: read#      ( count -- string ) "stdio" get fread# ;
-    "stdio" get freadln ;
+: write      ( string -- )       "stdio" get fwrite ;
-
+: write-attr ( string style -- ) "stdio" get fwrite-attr ;
-: read1 ( count -- string )
+: print      ( string -- )       "stdio" get fprint ;
-    "stdio" get fread1 ;
+: terpri     ( -- )              "\n" write ;
-
+: close      ( -- )              "stdio" get fclose ;
-: read# ( count -- string )
-    "stdio" get fread# ;
-
-: write ( string -- )
-    "stdio" get fwrite ;
-
-: write-attr ( string style -- )
-    #! Write an attributed string to standard output.
-    "stdio" get fwrite-attr ;
 
 : write-icon ( resource -- )
     #! Write an icon. Eg, /library/icons/File.png
     "icon" swons unit "" swap write-attr ;
 
-: print ( string -- )
-    "stdio" get fprint ;
-
-: terpri ( -- )
-    #! Print a newline to standard output.
-    "\n" write ;
-
-: close ( -- )
-    "stdio" get fclose ;
-
 : with-stream ( stream quot -- )
     [ swap "stdio" set  [ close rethrow ] catch ] with-scope ;
 
@@ -80,12 +60,13 @@ USE: streams
         call "stdio" get stream>str
     ] with-stream ;
 
-: <stdio-stream> ( stream -- stream )
+TRAITS: stdio-stream
-    #! We disable fclose on stdio so that various tricks like
-    #! with-stream can work.
-    <extend-stream> [
-        ( string -- )
-        [ write "\n" write flush ] "fprint" set
 
-        [ ] "fclose" set
+M: stdio-stream fauto-flush ( -- )
-    ] extend ;
+    [ delegate get fflush ] bind ;M
+
+M: stdio-stream fclose ( -- )
+    drop ;M
+
+C: stdio-stream ( delegate -- stream )
+    [ delegate set ] extend ;C

library/io/stream-impl.factor

@@ -37,34 +37,33 @@ USE: stack
 USE: stdio
 USE: strings
 USE: namespaces
+USE: generic
 
-: <fd-stream> ( in out -- stream )
+TRAITS: fd-stream
-    #! Create a file descriptor stream object, wrapping a pair
-    #! of file descriptor handles for input and output.
-    <stream> [
-        "out" set
-        "in" set
 
-        ( str -- )
+M: fd-stream fwrite-attr ( str style stream -- )
-        [ "out" get blocking-write ] "fwrite" set
+    [ drop "out" get blocking-write ] bind ;M
 
-        ( -- str )
+M: fd-stream freadln ( stream -- str )
-        [ "in" get dup [ blocking-read-line ] when ] "freadln" set
+    [ "in" get dup [ blocking-read-line ] when ] bind ;M
 
-        ( count -- str )
+M: fd-stream fread# ( count stream -- str )
-        [
+    [ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ;M
-            "in" get dup [ blocking-read# ] [ nip ] ifte
-        ] "fread#" set
 
-        ( -- )
+M: fd-stream fflush ( stream -- )
-        [ "out" get [ blocking-flush ] when* ] "fflush" set
+    [ "out" get [ blocking-flush ] when* ] bind ;M
 
-        ( -- )
+M: fd-stream fauto-flush ( stream -- )
-        [
+    drop ;M
-            "out" get [ dup blocking-flush close-port ] when*
+
-            "in" get [ close-port ] when*
+M: fd-stream fclose ( -- )
-        ] "fclose" set
+    [
-    ] extend ;
+        "out" get [ dup blocking-flush close-port ] when*
+        "in" get [ close-port ] when*
+    ] bind ;M
+
+C: fd-stream ( in out -- stream )
+    [ "out" set "in" set ] extend ;C
 
 : <filecr> ( path -- stream )
     t f open-file <fd-stream> ;

library/io/stream.factor

@@ -32,72 +32,43 @@ USE: kernel
 USE: namespaces
 USE: stack
 USE: strings
+USE: generic
 
-! Generic functions, of sorts...
+GENERIC: fflush      ( stream -- )
-
+GENERIC: fauto-flush ( stream -- )
-: fflush ( stream -- )
+GENERIC: freadln     ( stream -- string )
-    [ "fflush" get call ] bind ;
+GENERIC: fread#      ( count stream -- string )
-
+GENERIC: fwrite-attr ( string style stream -- )
-: freadln ( stream -- string )
+GENERIC: fclose      ( stream -- )
-    [ "freadln" get call ] bind ;
 
 : fread1 ( stream -- string )
-    [ "fread1" get call ] bind ;
+    1 swap fread# dup f-or-"" [ 0 swap str-nth ] unless ;
-
-: fread# ( count stream -- string )
-    [ "fread#" get call ] bind ;
 
 : fprint ( string stream -- )
-    [ "fprint" get call ] bind ;
+    tuck fwrite "\n" over fwrite fauto-flush ;
 
 : fwrite ( string stream -- )
-    [ "fwrite" get call ] bind ;
+    f swap fwrite-attr ;
 
-: fwrite-attr ( string style stream -- )
+TRAITS: string-output-stream
-    #! Write an attributed string to the given stream.
-    #! Supported keys depend on the type of stream.
-    [ "fwrite-attr" get call ] bind ;
 
-: fclose ( stream -- )
+M: string-output-stream fwrite-attr ( string style stream -- )
-    [ "fclose" get call ] bind ;
+    [ drop "buf" get sbuf-append ] bind ;M
 
-: <stream> ( -- stream )
+M: string-output-stream fclose ( stream -- )
-    #! Create a stream object.
+    drop ;M
-    <namespace> [
-        ( -- string )
-        [ "freadln not implemented." throw  ] "freadln" set
-        ( -- string )
-        [
-            1 namespace fread# dup f-or-"" [
-                0 swap str-nth
-            ] unless
-        ] "fread1" set
-        ( count -- string )
-        [ "fread# not implemented."  throw  ] "fread#" set
-        ( string -- )
-        [ "fwrite not implemented."  throw  ] "fwrite" set
-        ( string style -- )
-        [ drop namespace fwrite             ] "fwrite-attr" set
-        ( -- )
-        [ ] "fflush" set
-        ( -- )
-        [ ] "fclose" set
-        ( string -- )
-        [
-            namespace fwrite
-            "\n" namespace fwrite
-        ] "fprint" set
-    ] extend ;
 
-: <string-output-stream> ( size -- stream )
+M: string-output-stream fflush ( stream -- )
-    #! Creates a new stream for writing to a string buffer.
+    drop ;M
-    <stream> [
+
-        <sbuf> "buf" set
+M: string-output-stream fauto-flush ( stream -- )
-        ( string -- )
+    drop ;M
-        [ "buf" get sbuf-append ] "fwrite" set
-    ] extend ;
 
 : stream>str ( stream -- string )
     #! Returns the string written to the given string output
     #! stream.
     [ "buf" get ] bind sbuf>str ;
+
+C: string-output-stream ( size -- stream )
+    #! Creates a new stream for writing to a string buffer.
+    [ <sbuf> "buf" set ] extend ;C

library/test/httpd/html.factor

@@ -44,6 +44,9 @@ USE: stack
     ] with-string
 ] unit-test
 
+: html-write-attr ( string style -- string )
+    [ write-attr ] with-html-stream ;
+
 [ "hello world" ]
 [
     [ "hello world" [ ] html-write-attr ] with-string

library/test/image.factor

@@ -6,7 +6,7 @@ USE: stdio
 [ "ab\0\0" ] [ 4 "ab" align-string ] unit-test
 
 [ { 0 } ] [
-    [ "\0\0\0\0" emit-string ] with-minimal-image
+    [ "\0\0\0\0" emit-chars ] with-minimal-image
 ] unit-test
 
 [ { 6815845 7077996 7274528 7798895 7471212 6553600 } ]

library/test/stream.factor

@@ -3,21 +3,38 @@ USE: namespaces
 USE: streams
 USE: stdio
 USE: test
-
+USE: stack
+USE: generic
 
 [ "xyzzy" ] [ [ "xyzzy" write ] with-string ] unit-test
 
+TRAITS: xyzzy-stream
+
+M: xyzzy-stream fwrite-attr ( str style stream -- )
+    [
+        drop "<" delegate get fwrite
+        delegate get fwrite
+        ">" delegate get fwrite
+    ] bind ;M
+
+M: xyzzy-stream fclose ( stream -- )
+    drop ;M
+
+M: xyzzy-stream fflush ( stream -- )
+    drop ;M
+
+M: xyzzy-stream fauto-flush ( stream -- )
+    drop ;M
+
+C: xyzzy-stream ( stream -- stream )
+    [ delegate set ] extend ;C
+
 [
     "<xyzzy>"
 ] [
     [
-        [
+        "stdio" get <xyzzy-stream> [
-            "stdio" get <extend-stream> [
-                [ "<" write write ">" write ] "fwrite" set
-                [ "<" write write ">" print ] "fprint" set
-            ] extend "stdio" set
-            
             "xyzzy" write
-        ] with-scope
+        ] with-stream
     ] with-string
 ] unit-test

library/tools/jedit-wire.factor

@@ -37,6 +37,7 @@ USE: stdio
 USE: streams
 USE: strings
 USE: words
+USE: generic
 
 ! Wire protocol for jEdit to evaluate Factor code.
 ! Packets are of the form:
@@ -71,35 +72,25 @@ USE: listener
 ! the client:
 ! 4 bytes -- length. -1 means EOF
 ! remaining -- input
-: jedit-read ( -- str )
-    CHAR: r write flush read-big-endian-32 read# ;
-
 : jedit-write-attr ( str style -- )
     CHAR: w write
     [ swap . . ] with-string
     dup str-length write-big-endian-32
     write ;
 
-: jedit-flush ( -- )
+TRAITS: jedit-stream
-    CHAR: f write flush ;
 
-: <jedit-stream> ( stream -- stream )
+M: jedit-stream freadln ( stream -- str )
-    <extend-stream> [
+    [ CHAR: r write flush read-big-endian-32 read# ] bind ;M
-        ( -- str )
+
-        [ jedit-read ] "freadln" set
+M: jedit-stream fwrite-attr ( str style stream -- )
-        ( str -- )
+    [ [ default-style ] unless* jedit-write-attr ] bind ;M
-        [
+
-            default-style jedit-write-attr
+M: jedit-stream fflush ( stream -- )
-        ] "fwrite" set
+    [ CHAR: f write flush ] bind ;M
-        ( str style -- )
+
-        [ jedit-write-attr ] "fwrite-attr" set
+C: jedit-stream ( stream -- stream )
-        ( string -- )
+    [ dup delegate set "stdio" set ] extend ;C
-        [
-            "\n" cat2 default-style jedit-write-attr
-        ] "fprint" set
-        ( -- )
-        [ jedit-flush ] "fflush" set
-    ] extend ;
 
 : stream-server ( -- )
     #! Execute this in the inferior Factor.

native/error.c

@@ -29,22 +29,27 @@ void throw_error(CELL error, bool keep_stacks)
 	siglongjmp(toplevel,1);
 }
 
-void primitive_throw(void)
-{
-	throw_error(dpop(),true);
-}
-
 void early_error(CELL error)
 {
 	if(userenv[BREAK_ENV] == F)
 	{
 		/* Crash at startup */
-		fprintf(stderr,"Error %ld thrown before BREAK_ENV set\n",to_fixnum(error));
+		if(type_of(error) == FIXNUM_TYPE)
+			fprintf(stderr,"Error: %ld\n",to_fixnum(error));
+		else if(type_of(error) == STRING_TYPE)
+			fprintf(stderr,"Error: %s\n",to_c_string(untag_string(error)));
 		fflush(stderr);
 		exit(1);
 	}
 }
 
+void primitive_throw(void)
+{
+	CELL error = dpop();
+	early_error(error);
+	throw_error(error,true);
+}
+
 void general_error(CELL error, CELL tagged)
 {
 	early_error(error);