steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

tuples used for i/o streams, removed traits metaclass

cvs
Slava Pestov 2005-01-30 20:57:25 +00:00
parent 93dc7ce736
commit 330db0497d
33 changed files with 273 additions and 839 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
factor/ExternalFactor.java
View File

@ -63,7 +63,6 @@ public class ExternalFactor extends DefaultVocabularyLookup
}
Log.log(Log.ERROR,this,"Cannot connect to Factor on port " + port);
if(in != null && out != null)
close();
} //}}}
@ -280,6 +279,8 @@ public class ExternalFactor extends DefaultVocabularyLookup
closed = true;
if(out != null)
{
try
{
/* don't care about response */
@ -290,10 +291,13 @@ public class ExternalFactor extends DefaultVocabularyLookup
// We don't care...
Log.log(Log.DEBUG,this,e);
}
}
try
{
if(in != null)
in.close();
if(out != null)
out.close();
}
catch(Exception e)

1
library/bootstrap/boot-stage2.factor
View File

@ -12,7 +12,6 @@ USING: kernel lists parser stdio words namespaces ;
"/library/generic/predicate.factor"
"/library/generic/union.factor"
"/library/generic/complement.factor"
"/library/generic/traits.factor"
"/library/generic/tuple.factor"
"/version.factor"

3
library/bootstrap/boot.factor
View File

@ -38,13 +38,11 @@ words hashtables ;
"/library/syntax/parser.factor" parse-resource append,
"/library/syntax/parse-stream.factor" parse-resource append,
"traits" [ "generic" ] search
"delegate" [ "generic" ] search
"object" [ "generic" ] search
vocabularies get [ "generic" off ] bind
reveal
reveal
reveal
@ -55,7 +53,6 @@ words hashtables ;
"/library/generic/predicate.factor" parse-resource append,
"/library/generic/union.factor" parse-resource append,
"/library/generic/complement.factor" parse-resource append,
"/library/generic/traits.factor" parse-resource append,
"/library/generic/tuple.factor" parse-resource append,
"/library/bootstrap/init.factor" parse-resource append,

2
library/bootstrap/primitives.factor
View File

@ -195,6 +195,8 @@ vocabularies get [
[[ "hashtables" "<hashtable>" ]]
[[ "kernel-internals" "<array>" ]]
[[ "kernel-internals" "<tuple>" ]]
[[ "kernel-internals" ">array" ]]
[[ "kernel-internals" ">tuple" ]]
] [
unswons create swap 1 + [ f define ] keep
] each drop

53
library/compiler/alien.factor
View File

@ -1,46 +1,9 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004, 2005 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.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USE: assembler
USE: compiler
USE: errors
USE: generic
USE: inference
USE: interpreter
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: parser
USE: words
USE: hashtables
USE: strings
USE: unparser
USING: assembler compiler errors generic inference interpreter
kernel lists math namespaces parser words hashtables strings
unparser ;
! Command line parameters specify libraries to load.
!
@ -133,10 +96,10 @@ SYMBOL: alien-parameters
: infer-alien ( -- )
[ object object object object ] ensure-d
dataflow-drop, pop-d literal-value
dataflow-drop, pop-d literal-value >r
dataflow-drop, pop-d literal-value
dataflow-drop, pop-d literal-value -rot
dataflow-drop, pop-d value-literal
dataflow-drop, pop-d value-literal >r
dataflow-drop, pop-d value-literal
dataflow-drop, pop-d value-literal -rot
r> swap alien-node ;
: box-parameter

4
library/generic/generic.factor
View File

@ -16,10 +16,6 @@ namespaces parser strings words vectors math math-internals ;
! - class: a user defined way of differentiating objects, either
! based on type, or some combination of type, predicate, or
! method map.
! - traits: a hashtable has traits of its traits slot is set to
! a hashtable mapping selector names to method definitions.
! The class of an object with traits is determined by the object
! identity of the traits method map.
! - metaclass: a metaclass is a symbol with a handful of word
! properties: "builtin-types" "priority"

104
library/generic/traits.factor
View File

@ -1,104 +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: generic
USE: errors
USE: hashtables
USE: kernel
USE: lists
USE: namespaces
USE: parser
USE: strings
USE: words
USE: vectors
! Traits metaclass for user-defined classes based on hashtables
: traits ( object -- symbol )
dup hashtable? [ \ traits swap hash ] [ drop f ] ifte ;
! Hashtable slot holding an optional delegate. Any undefined
! methods are called on the delegate. The object can also
! manually pass any methods on to the delegate.
SYMBOL: delegate
: traits-dispatch ( object selector -- object quot )
over traits over "methods" word-property hash* dup [
nip cdr ( method is defined )
] [
drop delegate rot hash [
swap traits-dispatch ( check delegate )
] [
[ undefined-method ] ( no delegate )
] ifte*
] ifte ;
: add-traits-dispatch ( word vtable -- )
>r unit [ car traits-dispatch call ] cons \ hashtable r>
set-vtable ;
\ traits [
( generic vtable definition class -- )
2drop add-traits-dispatch
] "add-method" set-word-property
\ traits [
drop hashtable "builtin-type" word-property unit
] "builtin-supertypes" set-word-property
\ traits 10 "priority" set-word-property
\ traits [ 2drop t ] "class<" set-word-property
: traits-predicate ( word -- )
#! foo? where foo is a traits type tests if the top of stack
#! is of this type.
dup predicate-word swap
[ swap traits eq? ] cons
define-compound ;
: TRAITS:
#! TRAITS: foo creates a new traits type. Instances can be
#! created with <foo>, and tested with foo?.
CREATE
dup define-symbol
dup \ traits "metaclass" set-word-property
traits-predicate ; parsing
: constructor-word ( word -- word )
word-name "<" swap ">" cat3 "in" get create ;
: define-constructor ( constructor traits definition -- )
>r
[ \ traits pick set-hash ] cons \ <namespace> swons
r> append define-compound ;
: C: ( -- constructor traits [ ] )
#! C: foo ... begins definition for <foo> where foo is a
#! traits type.
scan-word [ constructor-word ] keep
[ define-constructor ] [ ] ; parsing

51
library/generic/tuple.factor
View File

@ -9,7 +9,7 @@ kernel-internals math hashtables errors ;
[ 0 swap set-array-nth ] keep ;
: define-tuple-generic ( tuple word def -- )
over >r \ single-combination \ GENERIC: r> define-generic
over >r [ single-combination ] \ GENERIC: r> define-generic
define-method ;
: define-accessor ( word name n -- )
@ -21,6 +21,9 @@ kernel-internals math hashtables errors ;
"in" get create r> [ set-slot ] cons define-tuple-generic ;
: define-field ( word name n -- )
over "delegate" = [
pick over "delegate-field" set-word-property
] when
3dup define-accessor define-mutator ;
: tuple-predicate ( word -- )
@ -35,13 +38,15 @@ kernel-internals math hashtables errors ;
dup length [ 3 + ] project zip
[ uncons define-field ] each-with ;
: TUPLE:
#! Followed by a tuple name, then field names, then ;
CREATE
: begin-tuple ( word -- )
dup intern-symbol
dup tuple-predicate
dup define-promise
dup tuple "metaclass" set-word-property
tuple "metaclass" set-word-property ;
: TUPLE:
#! Followed by a tuple name, then field names, then ;
CREATE dup begin-tuple
string-mode on
[ string-mode off define-tuple ]
f ; parsing
@ -54,22 +59,40 @@ kernel-internals math hashtables errors ;
[ swap literal, \ make-tuple , append, ] make-list
r> swap define-compound ;
: TC:
: wrapper-constructor ( word -- quot )
"delegate-field" word-property [ set-slot ] cons
[ keep ] cons ;
: WRAPPER:
#! A wrapper is a tuple whose only slot is a delegate slot.
CREATE dup begin-tuple
dup [ "delegate" ] define-tuple
dup wrapper-constructor
tuple-constructor ; parsing
: C:
#! Followed by a tuple name, then constructor code, then ;
#! Constructor code executes with the empty tuple on the
#! stack.
scan-word [ tuple-constructor ] f ; parsing
: tuple-dispatch ( object selector -- object quot )
over class over "methods" word-property hash* dup [
nip cdr ( method is defined )
: tuple-delegate ( tuple -- obj )
>tuple dup class "delegate-field" word-property dup [
>fixnum slot
] [
2drop f
] ifte ; inline
: tuple-dispatch ( object selector -- object quot )
over class over "methods" word-property hash* [
cdr ( method is defined )
] [
over tuple-delegate [
rot drop swap tuple-dispatch ( check delegate )
] [
! drop delegate rot hash [
! swap tuple-dispatch ( check delegate )
! ] [
[ undefined-method ] ( no delegate )
! ] ifte*
] ifte ;
] ifte*
] ?ifte ;
: add-tuple-dispatch ( word vtable -- )
>r unit [ car tuple-dispatch call ] cons tuple r>

47
library/httpd/html.factor
View File

@ -1,41 +1,8 @@
! :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.
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: html
USE: lists
USE: kernel
USE: namespaces
USE: stdio
USE: streams
USE: strings
USE: unparser
USE: url-encoding
USE: presentation
USE: generic
USING: lists kernel namespaces stdio streams strings unparser
url-encoding presentation generic ;
: html-entities ( -- alist )
[
@ -120,10 +87,10 @@ USE: generic
drop call
] ifte ;
TRAITS: html-stream
TUPLE: html-stream delegate ;
M: html-stream fwrite-attr ( str style stream -- )
[
wrapper-stream-scope [
[
[
[ drop chars>entities write ] span-tag
@ -145,7 +112,7 @@ C: html-stream ( stream -- stream )
#! underline
#! size
#! link - an object path
[ dup delegate set stdio set ] extend ;
[ >r <wrapper-stream> r> set-html-stream-delegate ] keep ;
: with-html-stream ( quot -- )
[ stdio [ <html-stream> ] change call ] with-scope ;

45
library/httpd/httpd.factor
View File

@ -1,42 +1,8 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2003, 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.
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: httpd
USE: errors
USE: httpd-responder
USE: kernel
USE: lists
USE: logging
USE: namespaces
USE: stdio
USE: streams
USE: strings
USE: threads
USE: url-encoding
USING: errors httpd-responder kernel lists logging namespaces
stdio streams strings threads url-encoding ;
: httpd-log-stream ( -- stream )
#! Set httpd-log-file to save httpd log to a file.
@ -83,8 +49,7 @@ USE: url-encoding
: httpd-client ( socket -- )
[
[
stdio get "client" set log-client
read [ parse-request ] when*
stdio get log-client read [ parse-request ] when*
] with-stream
] try ;

49
library/inference/branches.factor
View File

@ -1,43 +1,8 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004, 2005 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.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USE: errors
USE: generic
USE: interpreter
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: strings
USE: vectors
USE: words
USE: hashtables
USE: prettyprint
USING: errors generic interpreter kernel lists math namespaces
strings vectors words hashtables prettyprint ;
: longest-vector ( list -- length )
[ vector-length ] map [ > ] top ;
@ -140,7 +105,7 @@ SYMBOL: cloned
#! Type propagation is chained.
[
unswons 2dup set-value-class
[ type-propagations get ] bind assoc propagate-type
value-type-prop assoc propagate-type
] when* ;
: infer-branch ( value -- namespace )
@ -148,7 +113,7 @@ SYMBOL: cloned
uncons propagate-type
dup value-recursion recursive-state set
copy-inference
literal-value dup infer-quot
value-literal dup infer-quot
#values values-node
handle-terminator
] extend ;
@ -212,7 +177,7 @@ SYMBOL: cloned
dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
gensym [
dup value-recursion recursive-state set
literal-value infer-quot
value-literal infer-quot
] (with-block) drop ;
: dynamic-ifte ( true false -- )
@ -239,7 +204,7 @@ SYMBOL: cloned
\ ifte [ infer-ifte ] "infer" set-word-property
: vtable>list ( value -- list )
dup value-recursion swap literal-value vector>list
dup value-recursion swap value-literal vector>list
[ over <literal> ] map nip ;
USE: kernel-internals

53
library/inference/inference.factor
View File

@ -60,57 +60,46 @@ SYMBOL: d-in
! Recursive state. An alist, mapping words to labels.
SYMBOL: recursive-state
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 -- )
! A value has the following slots in addition to those relating
! to generics above:
! An association list mapping values to [[ value class ]] pairs
SYMBOL: type-propagations
TUPLE: value literal class type-prop recursion ;
C: value ;
TUPLE: computed delegate ;
TRAITS: computed
C: computed ( class -- value )
[
\ value-class set
gensym \ literal-value set
type-propagations off
] extend ;
M: computed literal-value ( value -- obj )
<value> over set-computed-delegate
[ set-value-class ] keep ;
M: computed value-literal ( value -- obj )
"Cannot use a computed value literally." throw ;
M: computed value= ( literal value -- ? )
2drop f ;
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
M: computed value-class-and ( class value -- )
[ value-class class-and ] keep set-value-class ;
TUPLE: literal delegate ;
C: literal ( obj rstate -- value )
[
recursive-state set
\ literal-value set
type-propagations off
] extend ;
M: literal literal-value ( value -- obj )
[ \ literal-value get ] bind ;
<value> over set-literal-delegate
[ set-value-recursion ] keep
[ set-value-literal ] keep ;
M: literal value= ( literal value -- ? )
literal-value = ;
M: literal value-class ( value -- class )
literal-value class ;
value-literal = ;
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 ;
: (ensure-types) ( typelist n stack -- )
pick [
3dup >r >r car r> r> vector-nth value-class-and

48
library/inference/types.factor
View File

@ -1,44 +1,8 @@
! :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.
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USE: errors
USE: generic
USE: interpreter
USE: kernel
USE: kernel-internals
USE: lists
USE: math
USE: namespaces
USE: strings
USE: vectors
USE: words
USE: stdio
USE: prettyprint
USING: errors generic interpreter kernel kernel-internals
lists math namespaces strings vectors words stdio prettyprint ;
! Enhanced inference of primitives relating to data types.
! Optimizes type checks and slot access.
@ -65,7 +29,7 @@ USE: prettyprint
! \ slot [
! [ object fixnum ] ensure-d
! dataflow-drop, pop-d literal-value
! dataflow-drop, pop-d value-literal
! peek-d value-class builtin-supertypes dup length 1 = [
! cons \ slot [ [ object ] [ object ] ] (consume/produce)
! ] [
@ -84,7 +48,7 @@ USE: prettyprint
1 0 node-inputs
[ object ] consume-d
[ fixnum ] produce-d
r> peek-d [ type-propagations set ] bind
r> peek-d value-type-prop
1 0 node-outputs
] bind
] "infer" set-word-property

44
library/inference/words.factor
View File

@ -1,44 +1,8 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004, 2005 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.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USE: errors
USE: generic
USE: interpreter
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: strings
USE: vectors
USE: words
USE: hashtables
USE: parser
USE: prettyprint
USING: errors generic interpreter kernel lists math namespaces
strings vectors words hashtables parser prettyprint ;
: with-dataflow ( param op [[ in# out# ]] quot -- )
#! Take input parameters, execute quotation, take output
@ -194,7 +158,7 @@ M: symbol (apply-word) ( word -- )
gensym dup [
drop pop-d dup
value-recursion recursive-state set
literal-value infer-quot
value-literal infer-quot
] with-block drop ;
\ call [ infer-call ] "infer" set-word-property

61
library/io/ansi.factor
View File

@ -1,41 +1,14 @@
! :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.
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: ansi
USE: lists
USE: kernel
USE: namespaces
USE: stdio
USE: streams
USE: strings
USE: presentation
USE: generic
USING: lists kernel namespaces stdio streams strings
presentation generic ;
! Some words for outputting ANSI colors.
! <ansi-stream> raps 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
! black 0
! red 1
@ -75,21 +48,11 @@ USE: generic
: ansi-attr-string ( string style -- string )
[ ansi-attrs , reset , ] make-string ;
TRAITS: ansi-stream
WRAPPER: ansi-stream
M: ansi-stream fwrite-attr ( string style stream -- )
[
[ default-style ] unless* ansi-attr-string
delegate get fwrite
] bind ;
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
[ delegate set ] extend ;
>r [ default-style ] unless* ansi-attr-string r>
ansi-stream-delegate fwrite ;
IN: shells

2
library/io/io-internals.factor
View File

@ -76,5 +76,3 @@ BUILTIN: port 14
: blocking-copy ( in out -- )
[ add-copy-io-task (yield) ] callcc0
pending-io-error pending-io-error ;

7
library/io/logging.factor
View File

@ -41,10 +41,9 @@ USE: unparser
: log-error ( error -- )
"Error: " swap cat2 log ;
: log-client ( -- )
"client" get [
"Accepted connection from " swap
"client" swap hash cat2 log
: log-client ( client-stream -- )
client-stream-host [
"Accepted connection from " swap cat2 log
] when* ;
: with-logging ( quot -- )

61
library/io/network.factor
View File

@ -1,61 +1,32 @@
! :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.
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: streams
USE: io-internals
USE: errors
USE: hashtables
USE: kernel
USE: stdio
USE: strings
USE: namespaces
USE: unparser
USE: generic
USING: io-internals errors hashtables kernel stdio strings
namespaces unparser generic ;
TRAITS: server
TUPLE: server port ;
GENERIC: accept
M: server fclose ( stream -- )
[ "socket" get close-port ] bind ;
server-port close-port ;
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 ] extend ;
[ >r server-socket r> set-server-port ] keep ;
: <client-stream> ( host port in out -- stream )
<fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;
TUPLE: client-stream delegate host ;
C: client-stream ( host port in out -- stream )
#! fflush yields until connection is established.
[ >r <fd-stream> r> set-client-stream-delegate ] keep
[ >r ":" swap unparse cat3 r> set-client-stream-host ] keep
dup fflush ;
: <client> ( host port -- stream )
#! fflush yields until connection is established.
2dup client-socket <client-stream> dup fflush ;
2dup client-socket <client-stream> ;
M: server accept ( server -- client )
#! Accept a connection from a server socket.
"socket" swap hash blocking-accept <client-stream> ;
server-port blocking-accept <client-stream> ;

53
library/io/stdio.factor
View File

@ -1,38 +1,7 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2003, 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.
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: stdio
USE: errors
USE: kernel
USE: lists
USE: namespaces
USE: streams
USE: generic
USE: strings
USING: errors kernel lists namespaces streams generic strings ;
SYMBOL: stdio
@ -56,24 +25,14 @@ SYMBOL: stdio
: with-string ( quot -- str )
#! Execute a quotation, and push a string containing all
#! text printed by the quotation.
1024 <string-output-stream> [
1024 <string-output> [
call stdio get stream>str
] with-stream ;
TRAITS: stdio-stream
WRAPPER: stdio-stream
M: stdio-stream fauto-flush ( -- )
[ delegate get fflush ] bind ;
stdio-stream-delegate fflush ;
M: stdio-stream fclose ( -- )
drop ;
C: stdio-stream ( delegate -- stream )
[ delegate set ] extend ;
: with-prefix ( prefix quot -- )
#! Each line of output from the given quotation is prefixed
#! with a string.
swap stdio get <prefix-stream> [
stdio set call
] with-scope ; inline

62
library/io/stream-impl.factor
View File

@ -1,68 +1,36 @@
! :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.
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: stdio
DEFER: stdio
IN: streams
USE: io-internals
USE: errors
USE: hashtables
USE: kernel
USE: stdio
USE: strings
USE: namespaces
USE: generic
USING: io-internals errors hashtables kernel stdio strings
namespaces generic ;
TRAITS: fd-stream
TUPLE: fd-stream in out ;
M: fd-stream fwrite-attr ( str style stream -- )
[ drop "out" get blocking-write ] bind ;
nip fd-stream-out blocking-write ;
M: fd-stream freadln ( stream -- str )
[ "in" get dup [ blocking-read-line ] when ] bind ;
fd-stream-in dup [ blocking-read-line ] when ;
M: fd-stream fread# ( count stream -- str )
[ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ;
fd-stream-in dup [ blocking-read# ] [ nip ] ifte ;
M: fd-stream fflush ( stream -- )
[ "out" get [ blocking-flush ] when* ] bind ;
fd-stream-out [ blocking-flush ] when* ;
M: fd-stream fauto-flush ( stream -- )
drop ;
M: fd-stream fclose ( -- )
[
"out" get [ dup blocking-flush close-port ] when*
"in" get [ close-port ] when*
] bind ;
M: fd-stream fclose ( stream -- )
dup fd-stream-out [ dup blocking-flush close-port ] when*
fd-stream-in [ close-port ] when* ;
C: fd-stream ( in out -- stream )
[ "out" set "in" set ] extend ;
[ set-fd-stream-out ] keep
[ set-fd-stream-in ] keep ;
: <file-reader> ( path -- stream )
t f open-file <fd-stream> ;
@ -77,7 +45,7 @@ C: fd-stream ( in out -- stream )
#! Copy the contents of the fd-stream 'from' to the
#! fd-stream 'to'. Use fcopy; this word does not close
#! streams.
"out" swap hash >r "in" swap hash r> blocking-copy ;
fd-stream-out >r fd-stream-in r> blocking-copy ;
: fcopy ( from to -- )
#! Copy the contents of the fd-stream 'from' to the

88
library/io/stream.factor
View File

@ -1,37 +1,9 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2003, 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.
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: stdio
DEFER: stdio
IN: streams
USE: errors
USE: kernel
USE: namespaces
USE: strings
USE: generic
USE: lists
USING: errors kernel namespaces strings generic lists ;
GENERIC: fflush ( stream -- )
GENERIC: fauto-flush ( stream -- )
@ -52,46 +24,32 @@ GENERIC: fclose ( stream -- )
[ "\n" swap fwrite ] keep
fauto-flush ;
TRAITS: string-output-stream
! A stream that builds a string of all text written to it.
TUPLE: string-output buf ;
M: string-output-stream fwrite-attr ( string style stream -- )
[ drop "buf" get sbuf-append ] bind ;
M: string-output fwrite-attr ( string style stream -- )
nip string-output-buf sbuf-append ;
M: string-output-stream fclose ( stream -- )
drop ;
M: string-output-stream fflush ( stream -- )
drop ;
M: string-output-stream fauto-flush ( stream -- )
drop ;
M: string-output fclose ( stream -- ) drop ;
M: string-output fflush ( stream -- ) drop ;
M: string-output fauto-flush ( stream -- ) drop ;
: stream>str ( stream -- string )
#! Returns the string written to the given string output
#! stream.
[ "buf" get ] bind sbuf>str ;
string-output-buf sbuf>str ;
C: string-output-stream ( size -- stream )
C: string-output ( size -- stream )
#! Creates a new stream for writing to a string buffer.
[ <sbuf> "buf" set ] extend ;
[ >r <sbuf> r> set-string-output-buf ] keep ;
! Prefix stream prefixes each line with a given string.
TRAITS: prefix-stream
SYMBOL: prefix
SYMBOL: last-newline
! Sometimes, we want to have a delegating stream that uses stdio
! words.
TUPLE: wrapper-stream delegate scope ;
M: prefix-stream fwrite-attr ( string style stream -- )
C: wrapper-stream ( stream -- stream )
2dup set-wrapper-stream-delegate
[
last-newline get [
prefix get delegate get fwrite last-newline off
] when
dupd delegate get fwrite-attr
"\n" str-tail? [
last-newline on
] when
] bind ;
C: prefix-stream ( prefix stream -- stream )
[ last-newline on delegate set prefix set ] extend ;
>r <namespace> [ stdio set ] extend r>
set-wrapper-stream-scope
] keep ;

2
library/primitives.factor
View File

@ -185,6 +185,8 @@ hashtables ;
[ <hashtable> [ [ number ] [ hashtable ] ] ]
[ <array> [ [ number ] [ array ] ] ]
[ <tuple> [ [ number ] [ tuple ] ] ]
[ >array [ [ object ] [ array ] ] ]
[ >tuple [ [ object ] [ tuple ] ] ]
] [
2unlist dup string? [
"stack-effect" set-word-property

2
library/test/benchmark/strings.factor
View File

@ -21,4 +21,4 @@ USE: compiler
: string-benchmark ( n -- )
"abcdef" 10 [ 2dup string-step ] times 2drop ; compiled
[ ] [ 1000000 string-benchmark ] unit-test
[ ] [ 400000 string-benchmark ] unit-test

54
library/test/generic.factor
View File

@ -10,58 +10,6 @@ USE: lists
USE: vectors
USE: alien
TRAITS: test-traits
C: test-traits ;
[ t ] [ <test-traits> test-traits? ] unit-test
[ f ] [ "hello" test-traits? ] unit-test
[ f ] [ <namespace> test-traits? ] unit-test
GENERIC: foo
M: test-traits foo drop 12 ;
TRAITS: another-test
C: another-test ;
M: another-test foo drop 13 ;
[ 12 ] [ <test-traits> foo ] unit-test
[ 13 ] [ <another-test> foo ] unit-test
TRAITS: quux
C: quux ;
M: quux foo "foo" swap hash ;
[
"Hi"
] [
<quux> [
"Hi" "foo" set
] extend foo
] unit-test
TRAITS: ctr-test
C: ctr-test [ 5 "x" set ] extend ;
[
5
] [
<ctr-test> [ "x" get ] bind
] unit-test
TRAITS: del1
C: del1 ;
GENERIC: super
M: del1 super drop 5 ;
TRAITS: del2
C: del2 ( delegate -- del2 ) [ delegate set ] extend ;
[ 5 ] [ <del1> <del2> super ] unit-test
GENERIC: class-of
M: fixnum class-of drop "fixnum" ;
@ -140,8 +88,6 @@ M: very-funny gooey sq ;
[ number ] [ number object class-and ] unit-test
[ number ] [ object number class-and ] unit-test
[ t ] [ del1 builtin-supertypes [ integer? ] all? ] unit-test
[ cons ] [ [ 1 2 ] class ] unit-test
[ t ] [ \ generic \ compound class< ] unit-test

31
library/test/stream.factor
View File

@ -7,34 +7,3 @@ USE: generic
USE: kernel
[ "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: xyzzy-stream fclose ( stream -- )
drop ;
M: xyzzy-stream fflush ( stream -- )
drop ;
M: xyzzy-stream fauto-flush ( stream -- )
drop ;
C: xyzzy-stream ( stream -- stream )
[ delegate set ] extend ;
[
"<xyzzy>"
] [
[
stdio get <xyzzy-stream> [
"xyzzy" write
] with-stream
] with-string
] unit-test

2
library/tools/debugger.factor
View File

@ -157,9 +157,7 @@ M: object error. ( error -- )
: print-error ( error -- )
#! Print the error.
[
"! " [
in-parser? [ parse-dump ] when error.
] with-prefix
] [
flush-error-handler
] catch ;

10
library/tools/jedit-wire.factor
View File

@ -37,6 +37,7 @@ USE: streams
USE: strings
USE: words
USE: generic
USE: listener
! Wire protocol for jEdit to evaluate Factor code.
! Packets are of the form:
@ -46,7 +47,7 @@ USE: generic
!
! jEdit sends a packet with code to eval, it receives the output
! captured with with-string.
USE: listener
: write-packet ( string -- )
dup str-length write-big-endian-32 write flush ;
@ -77,19 +78,22 @@ USE: listener
dup str-length write-big-endian-32
write ;
TRAITS: jedit-stream
TUPLE: jedit-stream delegate ;
M: jedit-stream freadln ( stream -- str )
wrapper-stream-scope
[ CHAR: r write flush read-big-endian-32 read# ] bind ;
M: jedit-stream fwrite-attr ( str style stream -- )
wrapper-stream-scope
[ [ default-style ] unless* jedit-write-attr ] bind ;
M: jedit-stream fflush ( stream -- )
wrapper-stream-scope
[ CHAR: f write flush ] bind ;
C: jedit-stream ( stream -- stream )
[ dup delegate set stdio set ] extend ;
[ >r <wrapper-stream> r> set-jedit-stream-delegate ] keep ;
: stream-server ( -- )
#! Execute this in the inferior Factor.

46
library/tools/telnetd.factor
View File

@ -1,47 +1,11 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2003, 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.
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: telnetd
USE: errors
USE: listener
USE: kernel
USE: logging
USE: namespaces
USE: stdio
USE: streams
USE: threads
USE: parser
USING: errors listener kernel logging namespaces stdio streams
threads parser ;
: telnet-client ( socket -- )
dup [
"client" set
log-client
listener
] with-stream ;
dup [ log-client listener ] with-stream ;
: telnet-connection ( socket -- )
[ telnet-client ] in-thread drop ;

33
library/ui/console.factor
View File

@ -199,47 +199,37 @@ SYMBOL: redraw-console
! The console stream
! Restoring this continuation returns to the
! top-level console event loop.
SYMBOL: redraw-continuation
! Restoring this continuation with a string on the stack returns
! to the caller of freadln.
SYMBOL: input-continuation
TRAITS: console-stream
TUPLE: console-stream console redraw-continuation ;
C: console-stream ( console console-continuation -- stream )
[
redraw-continuation set
console set
] extend ;
[ set-console-stream-redraw-continuation ] keep
[ set-console-stream-console ] keep ;
M: console-stream fflush ( stream -- )
fauto-flush ;
M: console-stream fauto-flush ( stream -- )
[
console get [ redraw-console on ] bind
] bind ;
console-stream-console [ redraw-console on ] bind ;
M: console-stream freadln ( stream -- line )
[
[
console get [ input-continuation set ] bind
redraw-continuation get dup [
swap [
console-stream-console
[ input-continuation set ] bind
] keep
dup console-stream-redraw-continuation dup [
call
] [
drop f
] ifte
] callcc1
] bind ;
] callcc1 nip ;
M: console-stream fwrite-attr ( string style stream -- )
[
drop
console get [ console-write ] bind
] bind ;
nip console-stream-console [ console-write ] bind ;
M: console-stream fclose ( stream -- ) drop ;
@ -375,7 +365,6 @@ M: alien handle-event ( event -- ? )
check-event [ console-loop ] when ;
: console-quit ( -- )
redraw-continuation off
input-continuation get [ f swap call ] when*
SDL_Quit ;

10
native/array.c
View File

@ -31,6 +31,11 @@ void primitive_array(void)
dpush(tag_object(array(ARRAY_TYPE,capacity,F)));
}
void primitive_to_array(void)
{
type_check(ARRAY_TYPE,dpeek());
}
void primitive_tuple(void)
{
F_FIXNUM capacity = to_fixnum(dpop());
@ -40,6 +45,11 @@ void primitive_tuple(void)
dpush(tag_object(array(TUPLE_TYPE,capacity,F)));
}
void primitive_to_tuple(void)
{
type_check(TUPLE_TYPE,dpeek());
}
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
{
/* later on, do an optimization: if end of array is here, just grow */

2
native/array.h
View File

@ -13,7 +13,9 @@ INLINE F_ARRAY* untag_array(CELL tagged)
F_ARRAY* allot_array(CELL type, CELL capacity);
F_ARRAY* array(CELL type, CELL capacity, CELL fill);
void primitive_array(void);
void primitive_to_array(void);
void primitive_tuple(void);
void primitive_to_tuple(void);
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
void primitive_grow_array(void);
F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);

40
native/debug.c
View File

@ -15,6 +15,9 @@ bool equals(CELL obj1, CELL obj2)
CELL assoc(CELL alist, CELL key)
{
if(alist == F)
return F;
if(TAG(alist) != CONS_TYPE)
{
fprintf(stderr,"Not an alist: %ld\n",alist);
@ -36,6 +39,38 @@ CELL assoc(CELL alist, CELL key)
}
}
CELL hash(CELL hash, CELL key)
{
if(type_of(hash) != HASHTABLE_TYPE)
{
fprintf(stderr,"Not a hash: %ld\n",hash);
return F;
}
{
int i;
CELL array = ((F_HASHTABLE*)UNTAG(hash))->array;
F_ARRAY* a;
if(type_of(array) != ARRAY_TYPE)
{
fprintf(stderr,"Not an array: %ld\n",hash);
return F;
}
a = untag_array(array);
for(i = 0; i < untag_fixnum_fast(a->capacity); i++)
{
CELL value = assoc(get(AREF(a,i)),key);
if(value != F)
return value;
}
return F;
}
}
void print_cons(CELL cons)
{
fprintf(stderr,"[ ");
@ -59,7 +94,7 @@ void print_cons(CELL cons)
void print_word(F_WORD* word)
{
CELL name = assoc(word->plist,tag_object(from_c_string("name")));
CELL name = hash(word->plist,tag_object(from_c_string("name")));
if(type_of(name) == STRING_TYPE)
fprintf(stderr,"%s",to_c_string(untag_string(name)));
else
@ -83,6 +118,9 @@ void print_obj(CELL obj)
{
switch(type_of(obj))
{
case FIXNUM_TYPE:
fprintf(stderr,"%d",untag_fixnum_fast(obj));
break;
case CONS_TYPE:
print_cons(obj);
break;

4
native/primitives.c
View File

@ -176,7 +176,9 @@ void* primitives[] = {
primitive_grow_array,
primitive_hashtable,
primitive_array,
primitive_tuple
primitive_tuple,
primitive_to_array,
primitive_to_tuple
};
CELL primitive_to_xt(CELL primitive)