- jedit ==> jedit-word, jedit takes a file name\r
- command line parsing cleanup\r
- nicer way to combine two paths\r
-- OOP\r
+- finish OOP\r
- ditch object paths\r
- browser responder for word links in HTTPd; inspect responder for\r
objects\r
"/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/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"
[
boot
"Good morning!" print
+ flush
"/library/bootstrap/boot-stage2.factor" run-resource
] boot-quot set
: cross-compile-resource ( resource -- )
[
! Change behavior of ; and SYMBOL:
- [ pick USE: prettyprint . define, ] "define-hook" set
+ [ define, ] "define-hook" set
run-resource
] with-scope ;
( 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
: 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
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
: 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 ;
#! 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 )
USE: strings
USE: unparser
USE: url-encoding
+USE: presentation
+USE: generic
: html-entities ( -- alist )
[
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 ;
-
-: <html-stream> ( stream -- stream )
+ [
+ [ drop chars>entities write ] span-tag
+ ] file-link-tag
+ ] object-link-tag
+ ] icon-tag
+ ] bind ;M
+
+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
#! 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 ;
: 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 ;
: 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 ;
: 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 )
: 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 ;
: 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.
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.
\ 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
USE: stdio
USE: streams
USE: strings
+USE: presentation
+USE: generic
! Some words for outputting ANSI colors.
"ansi-fg" over assoc [ fg , ] when*
"ansi-bg" over assoc [ bg , ] when*
drop ;
-
+
: 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 ;
+++ /dev/null
-! :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 ;
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 ;
! 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
USE: namespaces
USE: stack
USE: streams
-
-: 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 ;
+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 -- ) "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 ;
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
+
+M: stdio-stream fauto-flush ( -- )
+ [ delegate get fflush ] bind ;M
+
+M: stdio-stream fclose ( -- )
+ drop ;M
- [ ] "fclose" set
- ] extend ;
+C: stdio-stream ( delegate -- stream )
+ [ delegate set ] extend ;C
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
-
- ( 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 ;
+TRAITS: fd-stream
+
+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
: <filecr> ( path -- stream )
t f open-file <fd-stream> ;
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
] with-string
] unit-test
+: html-write-attr ( string style -- string )
+ [ write-attr ] with-html-stream ;
+
[ "hello world" ]
[
[ "hello world" [ ] html-write-attr ] with-string
[ "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 } ]
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
USE: streams
USE: strings
USE: words
+USE: generic
! Wire protocol for jEdit to evaluate Factor code.
! Packets are of the form:
! 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.
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);
projects / factor.git / commitdiff