}
Log.log(Log.ERROR,this,"Cannot connect to Factor on port " + port);
- if(in != null && out != null)
- close();
+ close();
} //}}}
//{{{ openWireSocket() method
closed = true;
- try
+ if(out != null)
{
- /* don't care about response */
- sendEval("0 exit*");
- }
- catch(Exception e)
- {
- // We don't care...
- Log.log(Log.DEBUG,this,e);
+ try
+ {
+ /* don't care about response */
+ sendEval("0 exit*");
+ }
+ catch(Exception e)
+ {
+ // We don't care...
+ Log.log(Log.DEBUG,this,e);
+ }
}
try
{
- in.close();
- out.close();
+ if(in != null)
+ in.close();
+ if(out != null)
+ out.close();
}
catch(Exception e)
{
"/library/generic/predicate.factor"\r
"/library/generic/union.factor"\r
"/library/generic/complement.factor"\r
- "/library/generic/traits.factor"\r
"/library/generic/tuple.factor"\r
\r
"/version.factor"\r
"/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
"/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,
[[ "hashtables" "<hashtable>" ]]
[[ "kernel-internals" "<array>" ]]
[[ "kernel-internals" "<tuple>" ]]
+ [[ "kernel-internals" ">array" ]]
+ [[ "kernel-internals" ">tuple" ]]
] [
unswons create swap 1 + [ f define ] keep
] each drop
-! :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.
!
: 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
! - 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"
+++ /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: 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
[ 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 -- )
"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 -- )
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
[ 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-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* dup [
- nip cdr ( method is defined )
+ over class over "methods" word-property hash* [
+ cdr ( method is defined )
] [
- ! drop delegate rot hash [
- ! swap tuple-dispatch ( check delegate )
- ! ] [
+ over tuple-delegate [
+ rot drop 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>
-! :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 )
[
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
#! 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 ;
-! :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.
: httpd-client ( socket -- )
[
[
- stdio get "client" set log-client
- read [ parse-request ] when*
+ stdio get log-client read [ parse-request ] when*
] with-stream
] try ;
-! :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 ;
#! 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 )
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 ;
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 -- )
\ 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
! 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 ;
+ [ value-class class-and ] keep set-value-class ;
+
+TUPLE: literal delegate ;
-TRAITS: literal
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
-! :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.
! \ 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)
! ] [
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
-! :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
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
-! :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
: 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
: blocking-copy ( in out -- )
[ add-copy-io-task (yield) ] callcc0
pending-io-error pending-io-error ;
-
-
: 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 -- )
-! :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 ;
-: <client> ( host port -- stream )
+C: client-stream ( host port in out -- stream )
#! fflush yields until connection is established.
- 2dup client-socket <client-stream> dup fflush ;
+ [ >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 )
+ 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> ;
-! :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
: 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
-! :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> ;
#! 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
-! :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 -- )
[ "\n" swap fwrite ] keep
fauto-flush ;
-TRAITS: string-output-stream
-
-M: string-output-stream fwrite-attr ( string style stream -- )
- [ drop "buf" get sbuf-append ] bind ;
-
-M: string-output-stream fclose ( stream -- )
- drop ;
+! A stream that builds a string of all text written to it.
+TUPLE: string-output buf ;
-M: string-output-stream fflush ( stream -- )
- drop ;
+M: string-output fwrite-attr ( string style stream -- )
+ nip string-output-buf sbuf-append ;
-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 ;
[ <hashtable> [ [ number ] [ hashtable ] ] ]
[ <array> [ [ number ] [ array ] ] ]
[ <tuple> [ [ number ] [ tuple ] ] ]
+ [ >array [ [ object ] [ array ] ] ]
+ [ >tuple [ [ object ] [ tuple ] ] ]
] [
2unlist dup string? [
"stack-effect" set-word-property
: string-benchmark ( n -- )
"abcdef" 10 [ 2dup string-step ] times 2drop ; compiled
-[ ] [ 1000000 string-benchmark ] unit-test
+[ ] [ 400000 string-benchmark ] unit-test
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" ;
[ 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
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
: print-error ( error -- )
#! Print the error.
[
- "! " [
- in-parser? [ parse-dump ] when error.
- ] with-prefix
+ in-parser? [ parse-dump ] when error.
] [
flush-error-handler
] catch ;
USE: strings
USE: words
USE: generic
+USE: listener
! Wire protocol for jEdit to evaluate Factor code.
! Packets are of the form:
!
! 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 ;
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.
-! :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 ;
! 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 [
- call
- ] [
- drop f
- ] ifte
- ] callcc1
- ] bind ;
+ swap [
+ console-stream-console
+ [ input-continuation set ] bind
+ ] keep
+ dup console-stream-redraw-continuation dup [
+ call
+ ] [
+ drop f
+ ] ifte
+ ] 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 ;
check-event [ console-loop ] when ;
: console-quit ( -- )
- redraw-continuation off
input-continuation get [ f swap call ] when*
SDL_Quit ;
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());
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 */
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);
CELL assoc(CELL alist, CELL key)
{
+ if(alist == F)
+ return F;
+
if(TAG(alist) != CONS_TYPE)
{
fprintf(stderr,"Not an alist: %ld\n",alist);
}
}
+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,"[ ");
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
{
switch(type_of(obj))
{
+ case FIXNUM_TYPE:
+ fprintf(stderr,"%d",untag_fixnum_fast(obj));
+ break;
case CONS_TYPE:
print_cons(obj);
break;
primitive_grow_array,
primitive_hashtable,
primitive_array,
- primitive_tuple
+ primitive_tuple,
+ primitive_to_array,
+ primitive_to_tuple
};
CELL primitive_to_xt(CELL primitive)
projects / factor.git / commitdiff