fix literal dataflow, other fixes
Slava Pestov
parent
cfb85ef884
commit
46d15bc82c
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
: <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> [
|
||||
[ 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 <html-stream> "stdio" set call ] with-scope ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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> [
|
||||
( string style -- )
|
||||
[ ansi-attr-string write ] "fwrite-attr" set
|
||||
] extend ;
|
||||
[ delegate set ] extend ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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> [
|
||||
"socket" set
|
||||
|
||||
( -- )
|
||||
[ "socket" get close-port ] "fclose" set
|
||||
] extend ;
|
||||
[ server-socket "socket" set ] extend ;C
|
||||
|
||||
: <client-stream> ( host port in out -- stream )
|
||||
<fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
"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 ;
|
||||
|
||||
: <stdio-stream> ( stream -- stream )
|
||||
#! We disable fclose on stdio so that various tricks like
|
||||
#! with-stream can work.
|
||||
<extend-stream> [
|
||||
( 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
|
||||
|
|
|
|||
|
|
@ -37,34 +37,33 @@ USE: stack
|
|||
USE: stdio
|
||||
USE: strings
|
||||
USE: namespaces
|
||||
USE: generic
|
||||
|
||||
: <fd-stream> ( in out -- stream )
|
||||
#! Create a file descriptor stream object, wrapping a pair
|
||||
#! of file descriptor handles for input and output.
|
||||
<stream> [
|
||||
"out" set
|
||||
"in" set
|
||||
TRAITS: fd-stream
|
||||
|
||||
( str -- )
|
||||
[ "out" get blocking-write ] "fwrite" set
|
||||
M: fd-stream fwrite-attr ( str style stream -- )
|
||||
[ drop "out" get blocking-write ] bind ;M
|
||||
|
||||
( -- str )
|
||||
[ "in" get dup [ blocking-read-line ] when ] "freadln" set
|
||||
M: fd-stream freadln ( stream -- str )
|
||||
[ "in" get dup [ blocking-read-line ] when ] bind ;M
|
||||
|
||||
( count -- str )
|
||||
[
|
||||
"in" get dup [ blocking-read# ] [ nip ] ifte
|
||||
] "fread#" set
|
||||
M: fd-stream fread# ( count stream -- str )
|
||||
[ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ;M
|
||||
|
||||
( -- )
|
||||
[ "out" get [ blocking-flush ] when* ] "fflush" set
|
||||
M: fd-stream fflush ( stream -- )
|
||||
[ "out" get [ blocking-flush ] when* ] bind ;M
|
||||
|
||||
( -- )
|
||||
[
|
||||
"out" get [ dup blocking-flush close-port ] when*
|
||||
"in" get [ close-port ] when*
|
||||
] "fclose" set
|
||||
] extend ;
|
||||
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
|
||||
|
||||
: <filecr> ( path -- stream )
|
||||
t f open-file <fd-stream> ;
|
||||
|
|
|
|||
|
|
@ -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> ( -- stream )
|
||||
#! Create a stream object.
|
||||
<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 ;
|
||||
M: string-output-stream fclose ( stream -- )
|
||||
drop ;M
|
||||
|
||||
: <string-output-stream> ( size -- stream )
|
||||
#! Creates a new stream for writing to a string buffer.
|
||||
<stream> [
|
||||
<sbuf> "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.
|
||||
[ <sbuf> "buf" set ] extend ;C
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } ]
|
||||
|
|
|
|||
|
|
@ -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 <extend-stream> [
|
||||
[ "<" write write ">" write ] "fwrite" set
|
||||
[ "<" write write ">" print ] "fprint" set
|
||||
] extend "stdio" set
|
||||
|
||||
"stdio" get <xyzzy-stream> [
|
||||
"xyzzy" write
|
||||
] with-scope
|
||||
] with-stream
|
||||
] with-string
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
: <jedit-stream> ( stream -- stream )
|
||||
<extend-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.
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
Loading…
Reference in New Issue