diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 1a50de9b92..6134b7bd91 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 9208d6ef0b..2bfea1ba31 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 51a1050b8a..dae2a79723 100644 --- a/library/bootstrap/boot.factor +++ b/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 diff --git a/library/bootstrap/cross-compiler.factor b/library/bootstrap/cross-compiler.factor index a376d39ed7..ffc5f0d575 100644 --- a/library/bootstrap/cross-compiler.factor +++ b/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 ; diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index b5d5810f38..ca1b2d2d70 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -180,10 +180,10 @@ SYMBOL: boot-quot ( Words ) -: word, ( -- pointer ) - word-tag here-as word-tag >header emit - 0 HEX: fffffff random-int emit ( hashcode ) - 0 emit ; +: word, ( word -- pointer ) + word-tag here-as >r word-tag >header emit + hashcode emit ( hashcode ) + 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 diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index 55bfc069ad..0668d6ec95 100644 --- a/library/bootstrap/init-stage2.factor +++ b/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 -! 0 [ unit try-infer [ succ ] when ] each-word -! unparse write " words have a stack effect" print +"Inferring stack effects..." print +0 [ unit try-infer [ succ ] when ] each-word +unparse write " words have a stack effect" print "Bootstrapping is complete." print "Now, you can run ./f factor.image" print diff --git a/library/generic.factor b/library/generic.factor index 0b56b8ad9f..2928a71029 100644 --- a/library/generic.factor +++ b/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 ) diff --git a/library/httpd/html.factor b/library/httpd/html.factor index 353ab06d42..639d611753 100644 --- a/library/httpd/html.factor +++ b/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 - ] object-link-tag - ] icon-tag ; + [ + [ drop chars>entities write ] span-tag + ] file-link-tag + ] object-link-tag + ] icon-tag + ] bind ;M -: ( 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 - [ - [ chars>entities write ] "fwrite" set - [ chars>entities print ] "fprint" set - [ html-write-attr ] "fwrite-attr" set - ] extend ; + [ dup delegate set "stdio" set ] extend ; : with-html-stream ( quot -- ) [ "stdio" get "stdio" set call ] with-scope ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 2d5d31b0bc..41fbf1305a 100644 --- a/library/inference/branches.factor +++ b/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 - \ drop CALL dataflow, drop pop-d 2list + dataflow-drop, pop-d + 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 ) diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index 36a017d0d9..2b892a538d 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -89,3 +89,8 @@ SYMBOL: node-param : dataflow, ( param op -- node ) #! Add a node to the dataflow IR. 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 ; diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 3bfa08d46f..cba598a45c 100644 --- a/library/inference/inference.factor +++ b/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. diff --git a/library/inference/stack.factor b/library/inference/stack.factor index c449a32556..5b9443ccd5 100644 --- a/library/inference/stack.factor +++ b/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 diff --git a/library/io/ansi.factor b/library/io/ansi.factor index 4b47426d77..160218a5da 100644 --- a/library/io/ansi.factor +++ b/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. @@ -72,17 +74,22 @@ USE: strings "ansi-fg" over assoc [ fg , ] when* "ansi-bg" over assoc [ bg , ] when* drop ; - + : ansi-attr-string ( string style -- string ) [ ansi-attrs , reset , ] make-string ; -: ( 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 - [ - ( string style -- ) - [ ansi-attr-string write ] "fwrite-attr" set - ] extend ; + [ delegate set ] extend ; diff --git a/library/io/extend-stream.factor b/library/io/extend-stream.factor deleted file mode 100644 index 28d9dc7c8b..0000000000 --- a/library/io/extend-stream.factor +++ /dev/null @@ -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 - -: ( stream -- stream ) - #! Create a stream that wraps another stream. Override some - #! or all of the stream words. - [ - "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 ; diff --git a/library/io/network.factor b/library/io/network.factor index 99bc281cd0..bca390ed83 100644 --- a/library/io/network.factor +++ b/library/io/network.factor @@ -38,17 +38,18 @@ USE: stdio USE: strings USE: namespaces USE: unparser +USE: generic -: ( 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 [ - "socket" set - - ( -- ) - [ "socket" get close-port ] "fclose" set - ] extend ; + [ server-socket "socket" set ] extend ;C : ( host port in out -- stream ) [ ":" swap unparse cat3 "client" set ] extend ; diff --git a/library/io/stdio.factor b/library/io/stdio.factor index b8d8360a73..f0ada997d0 100644 --- a/library/io/stdio.factor +++ b/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: - IN: stdio USE: combinators USE: errors @@ -36,40 +33,23 @@ USE: lists USE: namespaces USE: stack USE: streams +USE: generic +USE: strings -: flush ( -- ) - "stdio" get fflush ; - -: read ( -- string ) - "stdio" get freadln ; - -: read1 ( count -- string ) - "stdio" get fread1 ; - -: 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 ; +: flush ( -- ) "stdio" get fflush ; +: read ( -- string ) "stdio" get freadln ; +: read1 ( count -- string ) "stdio" get fread1 ; +: read# ( count -- string ) "stdio" get fread# ; +: write ( string -- ) "stdio" get fwrite ; +: write-attr ( string style -- ) "stdio" get fwrite-attr ; +: print ( string -- ) "stdio" get fprint ; +: terpri ( -- ) "\n" write ; +: close ( -- ) "stdio" get fclose ; : 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 ; -: ( stream -- stream ) - #! We disable fclose on stdio so that various tricks like - #! with-stream can work. - [ - ( string -- ) - [ write "\n" write flush ] "fprint" set +TRAITS: stdio-stream - [ ] "fclose" set - ] extend ; +M: stdio-stream fauto-flush ( -- ) + [ delegate get fflush ] bind ;M + +M: stdio-stream fclose ( -- ) + drop ;M + +C: stdio-stream ( delegate -- stream ) + [ delegate set ] extend ;C diff --git a/library/io/stream-impl.factor b/library/io/stream-impl.factor index acca4d19d1..4cbbacf7f6 100644 --- a/library/io/stream-impl.factor +++ b/library/io/stream-impl.factor @@ -37,34 +37,33 @@ USE: stack USE: stdio USE: strings USE: namespaces +USE: generic -: ( in out -- stream ) - #! Create a file descriptor stream object, wrapping a pair - #! of file descriptor handles for input and output. - [ - "out" set - "in" set +TRAITS: fd-stream - ( str -- ) - [ "out" get blocking-write ] "fwrite" set - - ( -- str ) - [ "in" get dup [ blocking-read-line ] when ] "freadln" set - - ( count -- str ) - [ - "in" get dup [ blocking-read# ] [ nip ] ifte - ] "fread#" set - - ( -- ) - [ "out" get [ blocking-flush ] when* ] "fflush" set - - ( -- ) - [ - "out" get [ dup blocking-flush close-port ] when* - "in" get [ close-port ] when* - ] "fclose" set - ] extend ; +M: fd-stream fwrite-attr ( str style stream -- ) + [ drop "out" get blocking-write ] bind ;M + +M: fd-stream freadln ( stream -- str ) + [ "in" get dup [ blocking-read-line ] when ] bind ;M + +M: fd-stream fread# ( count stream -- str ) + [ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ;M + +M: fd-stream fflush ( stream -- ) + [ "out" get [ blocking-flush ] when* ] bind ;M + +M: fd-stream fauto-flush ( stream -- ) + drop ;M + +M: fd-stream fclose ( -- ) + [ + "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 : ( path -- stream ) t f open-file ; diff --git a/library/io/stream.factor b/library/io/stream.factor index b7396f67f1..3659a0c36a 100644 --- a/library/io/stream.factor +++ b/library/io/stream.factor @@ -32,72 +32,43 @@ USE: kernel USE: namespaces USE: stack USE: strings +USE: generic -! Generic functions, of sorts... - -: fflush ( stream -- ) - [ "fflush" get call ] bind ; - -: freadln ( stream -- string ) - [ "freadln" get call ] bind ; +GENERIC: fflush ( stream -- ) +GENERIC: fauto-flush ( stream -- ) +GENERIC: freadln ( stream -- string ) +GENERIC: fread# ( count stream -- string ) +GENERIC: fwrite-attr ( string style stream -- ) +GENERIC: fclose ( stream -- ) : fread1 ( stream -- string ) - [ "fread1" get call ] bind ; - -: fread# ( count stream -- string ) - [ "fread#" get call ] bind ; + 1 swap fread# dup f-or-"" [ 0 swap str-nth ] unless ; : 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 -- ) - #! Write an attributed string to the given stream. - #! Supported keys depend on the type of stream. - [ "fwrite-attr" get call ] bind ; +TRAITS: string-output-stream -: fclose ( stream -- ) - [ "fclose" get call ] bind ; +M: string-output-stream fwrite-attr ( string style stream -- ) + [ drop "buf" get sbuf-append ] bind ;M -: ( -- stream ) - #! Create a stream object. - [ - ( -- 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 ; +M: string-output-stream fclose ( stream -- ) + drop ;M -: ( size -- stream ) - #! Creates a new stream for writing to a string buffer. - [ - "buf" set - ( string -- ) - [ "buf" get sbuf-append ] "fwrite" set - ] extend ; +M: string-output-stream fflush ( stream -- ) + drop ;M + +M: string-output-stream fauto-flush ( stream -- ) + drop ;M : 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. + [ "buf" set ] extend ;C diff --git a/library/test/httpd/html.factor b/library/test/httpd/html.factor index fdff7b246b..d8d974c645 100644 --- a/library/test/httpd/html.factor +++ b/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 diff --git a/library/test/image.factor b/library/test/image.factor index 22203b3fc4..ae3422f558 100644 --- a/library/test/image.factor +++ b/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 } ] diff --git a/library/test/stream.factor b/library/test/stream.factor index 6e7f3af1e9..ed6aae76d2 100644 --- a/library/test/stream.factor +++ b/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 + [ "" ] [ [ - [ - "stdio" get [ - [ "<" write write ">" write ] "fwrite" set - [ "<" write write ">" print ] "fprint" set - ] extend "stdio" set - + "stdio" get [ "xyzzy" write - ] with-scope + ] with-stream ] with-string ] unit-test diff --git a/library/tools/jedit-wire.factor b/library/tools/jedit-wire.factor index 69da9fedc1..d8904b8205 100644 --- a/library/tools/jedit-wire.factor +++ b/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 ( -- ) - CHAR: f write flush ; +TRAITS: jedit-stream -: ( stream -- stream ) - [ - ( -- str ) - [ jedit-read ] "freadln" set - ( str -- ) - [ - default-style jedit-write-attr - ] "fwrite" set - ( str style -- ) - [ jedit-write-attr ] "fwrite-attr" set - ( string -- ) - [ - "\n" cat2 default-style jedit-write-attr - ] "fprint" set - ( -- ) - [ jedit-flush ] "fflush" set - ] extend ; +M: jedit-stream freadln ( stream -- str ) + [ CHAR: r write flush read-big-endian-32 read# ] bind ;M + +M: jedit-stream fwrite-attr ( str style stream -- ) + [ [ default-style ] unless* jedit-write-attr ] bind ;M + +M: jedit-stream fflush ( stream -- ) + [ CHAR: f write flush ] bind ;M + +C: jedit-stream ( stream -- stream ) + [ dup delegate set "stdio" set ] extend ;C : stream-server ( -- ) #! Execute this in the inferior Factor. diff --git a/native/error.c b/native/error.c index d10168a95e..0b8ddbe59b 100644 --- a/native/error.c +++ b/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);