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

28
factor/ExternalFactor.java
View File

@ -63,8 +63,7 @@ public class ExternalFactor extends DefaultVocabularyLookup
} }
Log.log(Log.ERROR,this,"Cannot connect to Factor on port " + port); Log.log(Log.ERROR,this,"Cannot connect to Factor on port " + port);
if(in != null && out != null) close();
close();
} //}}} } //}}}
//{{{ openWireSocket() method //{{{ openWireSocket() method
@ -280,21 +279,26 @@ public class ExternalFactor extends DefaultVocabularyLookup
closed = true; closed = true;
try if(out != null)
{ {
/* don't care about response */ try
sendEval("0 exit*"); {
} /* don't care about response */
catch(Exception e) sendEval("0 exit*");
{ }
// We don't care... catch(Exception e)
Log.log(Log.DEBUG,this,e); {
// We don't care...
Log.log(Log.DEBUG,this,e);
}
} }
try try
{ {
in.close(); if(in != null)
out.close(); in.close();
if(out != null)
out.close();
} }
catch(Exception e) 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/predicate.factor"
"/library/generic/union.factor" "/library/generic/union.factor"
"/library/generic/complement.factor" "/library/generic/complement.factor"
"/library/generic/traits.factor"
"/library/generic/tuple.factor" "/library/generic/tuple.factor"
"/version.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/parser.factor" parse-resource append,
"/library/syntax/parse-stream.factor" parse-resource append, "/library/syntax/parse-stream.factor" parse-resource append,
"traits" [ "generic" ] search
"delegate" [ "generic" ] search "delegate" [ "generic" ] search
"object" [ "generic" ] search "object" [ "generic" ] search
vocabularies get [ "generic" off ] bind vocabularies get [ "generic" off ] bind
reveal
reveal reveal
reveal reveal
@ -55,7 +53,6 @@ words hashtables ;
"/library/generic/predicate.factor" parse-resource append, "/library/generic/predicate.factor" parse-resource append,
"/library/generic/union.factor" parse-resource append, "/library/generic/union.factor" parse-resource append,
"/library/generic/complement.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/generic/tuple.factor" parse-resource append,
"/library/bootstrap/init.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>" ]] [[ "hashtables" "<hashtable>" ]]
[[ "kernel-internals" "<array>" ]] [[ "kernel-internals" "<array>" ]]
[[ "kernel-internals" "<tuple>" ]] [[ "kernel-internals" "<tuple>" ]]
[[ "kernel-internals" ">array" ]]
[[ "kernel-internals" ">tuple" ]]
] [ ] [
unswons create swap 1 + [ f define ] keep unswons create swap 1 + [ f define ] keep
] each drop ] each drop

53
library/compiler/alien.factor
View File

@ -1,46 +1,9 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! ! See http://factor.sf.net/license.txt for BSD license.
! 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: alien IN: alien
USE: assembler USING: assembler compiler errors generic inference interpreter
USE: compiler kernel lists math namespaces parser words hashtables strings
USE: errors unparser ;
USE: generic
USE: inference
USE: interpreter
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: parser
USE: words
USE: hashtables
USE: strings
USE: unparser
! Command line parameters specify libraries to load. ! Command line parameters specify libraries to load.
! !
@ -133,10 +96,10 @@ SYMBOL: alien-parameters
: infer-alien ( -- ) : infer-alien ( -- )
[ object object object object ] ensure-d [ object object object object ] ensure-d
dataflow-drop, pop-d literal-value dataflow-drop, pop-d value-literal
dataflow-drop, pop-d literal-value >r dataflow-drop, pop-d value-literal >r
dataflow-drop, pop-d literal-value dataflow-drop, pop-d value-literal
dataflow-drop, pop-d literal-value -rot dataflow-drop, pop-d value-literal -rot
r> swap alien-node ; r> swap alien-node ;
: box-parameter : 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 ! - class: a user defined way of differentiating objects, either
! based on type, or some combination of type, predicate, or ! based on type, or some combination of type, predicate, or
! method map. ! 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 ! - metaclass: a metaclass is a symbol with a handful of word
! properties: "builtin-types" "priority" ! 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 ; [ 0 swap set-array-nth ] keep ;
: define-tuple-generic ( tuple word def -- ) : 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-method ;
: define-accessor ( word name n -- ) : define-accessor ( word name n -- )
@ -21,6 +21,9 @@ kernel-internals math hashtables errors ;
"in" get create r> [ set-slot ] cons define-tuple-generic ; "in" get create r> [ set-slot ] cons define-tuple-generic ;
: define-field ( word name n -- ) : define-field ( word name n -- )
over "delegate" = [
pick over "delegate-field" set-word-property
] when
3dup define-accessor define-mutator ; 3dup define-accessor define-mutator ;
: tuple-predicate ( word -- ) : tuple-predicate ( word -- )
@ -35,13 +38,15 @@ kernel-internals math hashtables errors ;
dup length [ 3 + ] project zip dup length [ 3 + ] project zip
[ uncons define-field ] each-with ; [ uncons define-field ] each-with ;
: TUPLE: : begin-tuple ( word -- )
#! Followed by a tuple name, then field names, then ;
CREATE
dup intern-symbol dup intern-symbol
dup tuple-predicate dup tuple-predicate
dup define-promise 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 on
[ string-mode off define-tuple ] [ string-mode off define-tuple ]
f ; parsing f ; parsing
@ -54,22 +59,40 @@ kernel-internals math hashtables errors ;
[ swap literal, \ make-tuple , append, ] make-list [ swap literal, \ make-tuple , append, ] make-list
r> swap define-compound ; 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 ; #! Followed by a tuple name, then constructor code, then ;
#! Constructor code executes with the empty tuple on the #! Constructor code executes with the empty tuple on the
#! stack. #! stack.
scan-word [ tuple-constructor ] f ; parsing scan-word [ tuple-constructor ] f ; parsing
: tuple-dispatch ( object selector -- object quot ) : tuple-delegate ( tuple -- obj )
over class over "methods" word-property hash* dup [ >tuple dup class "delegate-field" word-property dup [
nip cdr ( method is defined ) >fixnum slot
] [ ] [
! drop delegate rot hash [ 2drop f
! swap tuple-dispatch ( check delegate ) ] 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 )
] [
[ undefined-method ] ( no delegate ) [ undefined-method ] ( no delegate )
! ] ifte* ] ifte*
] ifte ; ] ?ifte ;
: add-tuple-dispatch ( word vtable -- ) : add-tuple-dispatch ( word vtable -- )
>r unit [ car tuple-dispatch call ] cons tuple r> >r unit [ car tuple-dispatch call ] cons tuple r>

47
library/httpd/html.factor
View File

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

45
library/httpd/httpd.factor
View File

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

49
library/inference/branches.factor
View File

@ -1,43 +1,8 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! ! See http://factor.sf.net/license.txt for BSD license.
! 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: inference IN: inference
USE: errors USING: errors generic interpreter kernel lists math namespaces
USE: generic strings vectors words hashtables prettyprint ;
USE: interpreter
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: strings
USE: vectors
USE: words
USE: hashtables
USE: prettyprint
: longest-vector ( list -- length ) : longest-vector ( list -- length )
[ vector-length ] map [ > ] top ; [ vector-length ] map [ > ] top ;
@ -140,7 +105,7 @@ SYMBOL: cloned
#! Type propagation is chained. #! Type propagation is chained.
[ [
unswons 2dup set-value-class unswons 2dup set-value-class
[ type-propagations get ] bind assoc propagate-type value-type-prop assoc propagate-type
] when* ; ] when* ;
: infer-branch ( value -- namespace ) : infer-branch ( value -- namespace )
@ -148,7 +113,7 @@ SYMBOL: cloned
uncons propagate-type uncons propagate-type
dup value-recursion recursive-state set dup value-recursion recursive-state set
copy-inference copy-inference
literal-value dup infer-quot value-literal dup infer-quot
#values values-node #values values-node
handle-terminator handle-terminator
] extend ; ] extend ;
@ -212,7 +177,7 @@ SYMBOL: cloned
dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
gensym [ gensym [
dup value-recursion recursive-state set dup value-recursion recursive-state set
literal-value infer-quot value-literal infer-quot
] (with-block) drop ; ] (with-block) drop ;
: dynamic-ifte ( true false -- ) : dynamic-ifte ( true false -- )
@ -239,7 +204,7 @@ SYMBOL: cloned
\ ifte [ infer-ifte ] "infer" set-word-property \ ifte [ infer-ifte ] "infer" set-word-property
: vtable>list ( value -- list ) : vtable>list ( value -- list )
dup value-recursion swap literal-value vector>list dup value-recursion swap value-literal vector>list
[ over <literal> ] map nip ; [ over <literal> ] map nip ;
USE: kernel-internals 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. ! Recursive state. An alist, mapping words to labels.
SYMBOL: recursive-state SYMBOL: recursive-state
GENERIC: literal-value ( value -- obj )
GENERIC: value= ( literal value -- ? ) GENERIC: value= ( literal value -- ? )
GENERIC: value-class ( value -- class )
GENERIC: value-class-and ( class value -- ) GENERIC: value-class-and ( class value -- )
GENERIC: set-value-class ( class value -- )
! A value has the following slots in addition to those relating ! A value has the following slots in addition to those relating
! to generics above: ! to generics above:
! An association list mapping values to [[ value class ]] pairs TUPLE: value literal class type-prop recursion ;
SYMBOL: type-propagations C: value ;
TUPLE: computed delegate ;
TRAITS: computed
C: computed ( class -- value ) C: computed ( class -- value )
[ <value> over set-computed-delegate
\ value-class set [ set-value-class ] keep ;
gensym \ literal-value set
type-propagations off M: computed value-literal ( value -- obj )
] extend ;
M: computed literal-value ( value -- obj )
"Cannot use a computed value literally." throw ; "Cannot use a computed value literally." throw ;
M: computed value= ( literal value -- ? ) M: computed value= ( literal value -- ? )
2drop f ; 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 ) C: literal ( obj rstate -- value )
[ <value> over set-literal-delegate
recursive-state set [ set-value-recursion ] keep
\ literal-value set [ set-value-literal ] keep ;
type-propagations off
] extend ;
M: literal literal-value ( value -- obj )
[ \ literal-value get ] bind ;
M: literal value= ( literal value -- ? ) M: literal value= ( literal value -- ? )
literal-value = ; value-literal = ;
M: literal value-class ( value -- class )
literal-value class ;
M: literal value-class-and ( class value -- ) M: literal value-class-and ( class value -- )
value-class class-and drop ; value-class class-and drop ;
M: literal set-value-class ( class value -- ) M: literal set-value-class ( class value -- )
2drop ; 2drop ;
: value-recursion ( value -- rstate )
[ recursive-state get ] bind ;
: (ensure-types) ( typelist n stack -- ) : (ensure-types) ( typelist n stack -- )
pick [ pick [
3dup >r >r car r> r> vector-nth value-class-and 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: ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! $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: inference IN: inference
USE: errors USING: errors generic interpreter kernel kernel-internals
USE: generic lists math namespaces strings vectors words stdio prettyprint ;
USE: interpreter
USE: kernel
USE: kernel-internals
USE: lists
USE: math
USE: namespaces
USE: strings
USE: vectors
USE: words
USE: stdio
USE: prettyprint
! Enhanced inference of primitives relating to data types. ! Enhanced inference of primitives relating to data types.
! Optimizes type checks and slot access. ! Optimizes type checks and slot access.
@ -65,7 +29,7 @@ USE: prettyprint
! \ slot [ ! \ slot [
! [ object fixnum ] ensure-d ! [ 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 = [ ! peek-d value-class builtin-supertypes dup length 1 = [
! cons \ slot [ [ object ] [ object ] ] (consume/produce) ! cons \ slot [ [ object ] [ object ] ] (consume/produce)
! ] [ ! ] [
@ -84,7 +48,7 @@ USE: prettyprint
1 0 node-inputs 1 0 node-inputs
[ object ] consume-d [ object ] consume-d
[ fixnum ] produce-d [ fixnum ] produce-d
r> peek-d [ type-propagations set ] bind r> peek-d value-type-prop
1 0 node-outputs 1 0 node-outputs
] bind ] bind
] "infer" set-word-property ] "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. ! Copyright (C) 2004, 2005 Slava Pestov.
! ! See http://factor.sf.net/license.txt for BSD license.
! 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: inference IN: inference
USE: errors USING: errors generic interpreter kernel lists math namespaces
USE: generic strings vectors words hashtables parser prettyprint ;
USE: interpreter
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: strings
USE: vectors
USE: words
USE: hashtables
USE: parser
USE: prettyprint
: with-dataflow ( param op [[ in# out# ]] quot -- ) : with-dataflow ( param op [[ in# out# ]] quot -- )
#! Take input parameters, execute quotation, take output #! Take input parameters, execute quotation, take output
@ -194,7 +158,7 @@ M: symbol (apply-word) ( word -- )
gensym dup [ gensym dup [
drop pop-d dup drop pop-d dup
value-recursion recursive-state set value-recursion recursive-state set
literal-value infer-quot value-literal infer-quot
] with-block drop ; ] with-block drop ;
\ call [ infer-call ] "infer" set-word-property \ call [ infer-call ] "infer" set-word-property

61
library/io/ansi.factor
View File

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

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

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

7
library/io/logging.factor
View File

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

61
library/io/network.factor
View File

@ -1,61 +1,32 @@
! :folding=indent:collapseFolds=1: ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: streams IN: streams
USE: io-internals USING: io-internals errors hashtables kernel stdio strings
USE: errors namespaces unparser generic ;
USE: hashtables
USE: kernel
USE: stdio
USE: strings
USE: namespaces
USE: unparser
USE: generic
TRAITS: server TUPLE: server port ;
GENERIC: accept GENERIC: accept
M: server fclose ( stream -- ) M: server fclose ( stream -- )
[ "socket" get close-port ] bind ; server-port close-port ;
C: server ( port -- stream ) C: server ( port -- stream )
#! Starts listening on localhost:port. Returns a stream that #! Starts listening on localhost:port. Returns a stream that
#! you can close with fclose, and accept connections from #! you can close with fclose, and accept connections from
#! with accept. No other stream operations are supported. #! 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 ) TUPLE: client-stream delegate host ;
<fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;
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 ) : <client> ( host port -- stream )
#! fflush yields until connection is established. 2dup client-socket <client-stream> ;
2dup client-socket <client-stream> dup fflush ;
M: server accept ( server -- client ) M: server accept ( server -- client )
#! Accept a connection from a server socket. #! 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: ! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! $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.
IN: stdio IN: stdio
USE: errors USING: errors kernel lists namespaces streams generic strings ;
USE: kernel
USE: lists
USE: namespaces
USE: streams
USE: generic
USE: strings
SYMBOL: stdio SYMBOL: stdio
@ -56,24 +25,14 @@ SYMBOL: stdio
: with-string ( quot -- str ) : with-string ( quot -- str )
#! Execute a quotation, and push a string containing all #! Execute a quotation, and push a string containing all
#! text printed by the quotation. #! text printed by the quotation.
1024 <string-output-stream> [ 1024 <string-output> [
call stdio get stream>str call stdio get stream>str
] with-stream ; ] with-stream ;
TRAITS: stdio-stream WRAPPER: stdio-stream
M: stdio-stream fauto-flush ( -- ) M: stdio-stream fauto-flush ( -- )
[ delegate get fflush ] bind ; stdio-stream-delegate fflush ;
M: stdio-stream fclose ( -- ) M: stdio-stream fclose ( -- )
drop ; 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: ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! $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: stdio IN: stdio
DEFER: stdio DEFER: stdio
IN: streams IN: streams
USE: io-internals USING: io-internals errors hashtables kernel stdio strings
USE: errors namespaces generic ;
USE: hashtables
USE: kernel
USE: stdio
USE: strings
USE: namespaces
USE: generic
TRAITS: fd-stream TUPLE: fd-stream in out ;
M: fd-stream fwrite-attr ( str style stream -- ) 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 ) 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 ) 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 -- ) M: fd-stream fflush ( stream -- )
[ "out" get [ blocking-flush ] when* ] bind ; fd-stream-out [ blocking-flush ] when* ;
M: fd-stream fauto-flush ( stream -- ) M: fd-stream fauto-flush ( stream -- )
drop ; drop ;
M: fd-stream fclose ( -- ) M: fd-stream fclose ( stream -- )
[ dup fd-stream-out [ dup blocking-flush close-port ] when*
"out" get [ dup blocking-flush close-port ] when* fd-stream-in [ close-port ] when* ;
"in" get [ close-port ] when*
] bind ;
C: fd-stream ( in out -- stream ) 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 ) : <file-reader> ( path -- stream )
t f open-file <fd-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 #! Copy the contents of the fd-stream 'from' to the
#! fd-stream 'to'. Use fcopy; this word does not close #! fd-stream 'to'. Use fcopy; this word does not close
#! streams. #! streams.
"out" swap hash >r "in" swap hash r> blocking-copy ; fd-stream-out >r fd-stream-in r> blocking-copy ;
: fcopy ( from to -- ) : fcopy ( from to -- )
#! Copy the contents of the fd-stream 'from' to the #! 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: ! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! $Id$ IN: stdio
! DEFER: stdio
! 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.
IN: streams IN: streams
USE: errors USING: errors kernel namespaces strings generic lists ;
USE: kernel
USE: namespaces
USE: strings
USE: generic
USE: lists
GENERIC: fflush ( stream -- ) GENERIC: fflush ( stream -- )
GENERIC: fauto-flush ( stream -- ) GENERIC: fauto-flush ( stream -- )
@ -52,46 +24,32 @@ GENERIC: fclose ( stream -- )
[ "\n" swap fwrite ] keep [ "\n" swap fwrite ] keep
fauto-flush ; 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 -- ) M: string-output fwrite-attr ( string style stream -- )
[ drop "buf" get sbuf-append ] bind ; nip string-output-buf sbuf-append ;
M: string-output-stream fclose ( stream -- ) M: string-output fclose ( stream -- ) drop ;
drop ; M: string-output fflush ( stream -- ) drop ;
M: string-output fauto-flush ( stream -- ) drop ;
M: string-output-stream fflush ( stream -- )
drop ;
M: string-output-stream fauto-flush ( stream -- )
drop ;
: stream>str ( stream -- string ) : stream>str ( stream -- string )
#! Returns the string written to the given string output #! Returns the string written to the given string output
#! stream. #! 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. #! 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. ! Sometimes, we want to have a delegating stream that uses stdio
TRAITS: prefix-stream ! words.
SYMBOL: prefix TUPLE: wrapper-stream delegate scope ;
SYMBOL: last-newline
M: prefix-stream fwrite-attr ( string style stream -- ) C: wrapper-stream ( stream -- stream )
2dup set-wrapper-stream-delegate
[ [
last-newline get [ >r <namespace> [ stdio set ] extend r>
prefix get delegate get fwrite last-newline off set-wrapper-stream-scope
] when ] keep ;
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 ;

2
library/primitives.factor
View File

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

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

@ -21,4 +21,4 @@ USE: compiler
: string-benchmark ( n -- ) : string-benchmark ( n -- )
"abcdef" 10 [ 2dup string-step ] times 2drop ; compiled "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: vectors
USE: alien 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 GENERIC: class-of
M: fixnum class-of drop "fixnum" ; M: fixnum class-of drop "fixnum" ;
@ -140,8 +88,6 @@ M: very-funny gooey sq ;
[ number ] [ number object class-and ] unit-test [ number ] [ number object class-and ] unit-test
[ number ] [ object number 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 [ cons ] [ [ 1 2 ] class ] unit-test
[ t ] [ \ generic \ compound class< ] unit-test [ t ] [ \ generic \ compound class< ] unit-test

31
library/test/stream.factor
View File

@ -7,34 +7,3 @@ USE: generic
USE: kernel USE: kernel
[ "xyzzy" ] [ [ "xyzzy" write ] with-string ] unit-test [ "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

4
library/tools/debugger.factor
View File

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

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

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

46
library/tools/telnetd.factor
View File

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

41
library/ui/console.factor
View File

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

10
native/array.c
View File

@ -31,6 +31,11 @@ void primitive_array(void)
dpush(tag_object(array(ARRAY_TYPE,capacity,F))); dpush(tag_object(array(ARRAY_TYPE,capacity,F)));
} }
void primitive_to_array(void)
{
type_check(ARRAY_TYPE,dpeek());
}
void primitive_tuple(void) void primitive_tuple(void)
{ {
F_FIXNUM capacity = to_fixnum(dpop()); F_FIXNUM capacity = to_fixnum(dpop());
@ -40,6 +45,11 @@ void primitive_tuple(void)
dpush(tag_object(array(TUPLE_TYPE,capacity,F))); 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) F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
{ {
/* later on, do an optimization: if end of array is here, just grow */ /* 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* allot_array(CELL type, CELL capacity);
F_ARRAY* array(CELL type, CELL capacity, CELL fill); F_ARRAY* array(CELL type, CELL capacity, CELL fill);
void primitive_array(void); void primitive_array(void);
void primitive_to_array(void);
void primitive_tuple(void); void primitive_tuple(void);
void primitive_to_tuple(void);
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill); F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
void primitive_grow_array(void); void primitive_grow_array(void);
F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); 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) CELL assoc(CELL alist, CELL key)
{ {
if(alist == F)
return F;
if(TAG(alist) != CONS_TYPE) if(TAG(alist) != CONS_TYPE)
{ {
fprintf(stderr,"Not an alist: %ld\n",alist); 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) void print_cons(CELL cons)
{ {
fprintf(stderr,"[ "); fprintf(stderr,"[ ");
@ -59,7 +94,7 @@ void print_cons(CELL cons)
void print_word(F_WORD* word) 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) if(type_of(name) == STRING_TYPE)
fprintf(stderr,"%s",to_c_string(untag_string(name))); fprintf(stderr,"%s",to_c_string(untag_string(name)));
else else
@ -83,6 +118,9 @@ void print_obj(CELL obj)
{ {
switch(type_of(obj)) switch(type_of(obj))
{ {
case FIXNUM_TYPE:
fprintf(stderr,"%d",untag_fixnum_fast(obj));
break;
case CONS_TYPE: case CONS_TYPE:
print_cons(obj); print_cons(obj);
break; break;

4
native/primitives.c
View File

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