diff --git a/factor/ExternalFactor.java b/factor/ExternalFactor.java index 6d6f6a6afc..78b5779ae9 100644 --- a/factor/ExternalFactor.java +++ b/factor/ExternalFactor.java @@ -63,8 +63,7 @@ public class ExternalFactor extends DefaultVocabularyLookup } Log.log(Log.ERROR,this,"Cannot connect to Factor on port " + port); - if(in != null && out != null) - close(); + close(); } //}}} //{{{ openWireSocket() method @@ -280,21 +279,26 @@ public class ExternalFactor extends DefaultVocabularyLookup 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) { diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 2ba7557c7b..9e7e0e142b 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -12,7 +12,6 @@ USING: kernel lists parser stdio words namespaces ; "/library/generic/predicate.factor" "/library/generic/union.factor" "/library/generic/complement.factor" - "/library/generic/traits.factor" "/library/generic/tuple.factor" "/version.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 64de946fe1..43d49a61b9 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -38,13 +38,11 @@ words hashtables ; "/library/syntax/parser.factor" parse-resource append, "/library/syntax/parse-stream.factor" parse-resource append, - "traits" [ "generic" ] search "delegate" [ "generic" ] search "object" [ "generic" ] search vocabularies get [ "generic" off ] bind - reveal reveal reveal @@ -55,7 +53,6 @@ words hashtables ; "/library/generic/predicate.factor" parse-resource append, "/library/generic/union.factor" parse-resource append, "/library/generic/complement.factor" parse-resource append, - "/library/generic/traits.factor" parse-resource append, "/library/generic/tuple.factor" parse-resource append, "/library/bootstrap/init.factor" parse-resource append, diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 744f4e7576..0ea76fd777 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -195,6 +195,8 @@ vocabularies get [ [[ "hashtables" "" ]] [[ "kernel-internals" "" ]] [[ "kernel-internals" "" ]] + [[ "kernel-internals" ">array" ]] + [[ "kernel-internals" ">tuple" ]] ] [ unswons create swap 1 + [ f define ] keep ] each drop diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 056ae65cc7..67e42248e7 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -1,46 +1,9 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: alien -USE: assembler -USE: compiler -USE: errors -USE: generic -USE: inference -USE: interpreter -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: parser -USE: words -USE: hashtables -USE: strings -USE: unparser +USING: assembler compiler errors generic inference interpreter +kernel lists math namespaces parser words hashtables strings +unparser ; ! Command line parameters specify libraries to load. ! @@ -133,10 +96,10 @@ SYMBOL: alien-parameters : infer-alien ( -- ) [ object object object object ] ensure-d - dataflow-drop, pop-d literal-value - dataflow-drop, pop-d literal-value >r - dataflow-drop, pop-d literal-value - dataflow-drop, pop-d literal-value -rot + dataflow-drop, pop-d value-literal + dataflow-drop, pop-d value-literal >r + dataflow-drop, pop-d value-literal + dataflow-drop, pop-d value-literal -rot r> swap alien-node ; : box-parameter diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 83410dc1ef..4aed76f502 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -16,10 +16,6 @@ namespaces parser strings words vectors math math-internals ; ! - class: a user defined way of differentiating objects, either ! based on type, or some combination of type, predicate, or ! method map. -! - traits: a hashtable has traits of its traits slot is set to -! a hashtable mapping selector names to method definitions. -! The class of an object with traits is determined by the object -! identity of the traits method map. ! - metaclass: a metaclass is a symbol with a handful of word ! properties: "builtin-types" "priority" diff --git a/library/generic/traits.factor b/library/generic/traits.factor deleted file mode 100644 index 12c2c88cf2..0000000000 --- a/library/generic/traits.factor +++ /dev/null @@ -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 , 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 \ swons - r> append define-compound ; - -: C: ( -- constructor traits [ ] ) - #! C: foo ... begins definition for where foo is a - #! traits type. - scan-word [ constructor-word ] keep - [ define-constructor ] [ ] ; parsing diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index e6224559d8..a47adedad0 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -9,7 +9,7 @@ kernel-internals math hashtables errors ; [ 0 swap set-array-nth ] keep ; : define-tuple-generic ( tuple word def -- ) - over >r \ single-combination \ GENERIC: r> define-generic + over >r [ single-combination ] \ GENERIC: r> define-generic define-method ; : define-accessor ( word name n -- ) @@ -21,6 +21,9 @@ kernel-internals math hashtables errors ; "in" get create r> [ set-slot ] cons define-tuple-generic ; : define-field ( word name n -- ) + over "delegate" = [ + pick over "delegate-field" set-word-property + ] when 3dup define-accessor define-mutator ; : tuple-predicate ( word -- ) @@ -35,13 +38,15 @@ kernel-internals math hashtables errors ; dup length [ 3 + ] project zip [ uncons define-field ] each-with ; -: TUPLE: - #! Followed by a tuple name, then field names, then ; - CREATE +: begin-tuple ( word -- ) dup intern-symbol dup tuple-predicate dup define-promise - dup tuple "metaclass" set-word-property + tuple "metaclass" set-word-property ; + +: TUPLE: + #! Followed by a tuple name, then field names, then ; + CREATE dup begin-tuple string-mode on [ string-mode off define-tuple ] f ; parsing @@ -54,22 +59,40 @@ kernel-internals math hashtables errors ; [ swap literal, \ make-tuple , append, ] make-list r> swap define-compound ; -: TC: +: wrapper-constructor ( word -- quot ) + "delegate-field" word-property [ set-slot ] cons + [ keep ] cons ; + +: WRAPPER: + #! A wrapper is a tuple whose only slot is a delegate slot. + CREATE dup begin-tuple + dup [ "delegate" ] define-tuple + dup wrapper-constructor + tuple-constructor ; parsing + +: C: #! Followed by a tuple name, then constructor code, then ; #! Constructor code executes with the empty tuple on the #! stack. scan-word [ tuple-constructor ] f ; parsing -: tuple-dispatch ( object selector -- object quot ) - over class over "methods" word-property hash* dup [ - nip cdr ( method is defined ) +: tuple-delegate ( tuple -- obj ) + >tuple dup class "delegate-field" word-property dup [ + >fixnum slot ] [ - ! drop delegate rot hash [ - ! swap tuple-dispatch ( check delegate ) - ! ] [ + 2drop f + ] ifte ; inline + +: tuple-dispatch ( object selector -- object quot ) + over class over "methods" word-property hash* [ + cdr ( method is defined ) + ] [ + over tuple-delegate [ + rot drop swap tuple-dispatch ( check delegate ) + ] [ [ undefined-method ] ( no delegate ) - ! ] ifte* - ] ifte ; + ] ifte* + ] ?ifte ; : add-tuple-dispatch ( word vtable -- ) >r unit [ car tuple-dispatch call ] cons tuple r> diff --git a/library/httpd/html.factor b/library/httpd/html.factor index 3d9fd7cd95..63946c13d1 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -1,41 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: html -USE: lists -USE: kernel -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: unparser -USE: url-encoding -USE: presentation -USE: generic +USING: lists kernel namespaces stdio streams strings unparser +url-encoding presentation generic ; : html-entities ( -- alist ) [ @@ -120,10 +87,10 @@ USE: generic drop call ] ifte ; -TRAITS: html-stream +TUPLE: html-stream delegate ; M: html-stream fwrite-attr ( str style stream -- ) - [ + wrapper-stream-scope [ [ [ [ drop chars>entities write ] span-tag @@ -145,7 +112,7 @@ C: html-stream ( stream -- stream ) #! underline #! size #! link - an object path - [ dup delegate set stdio set ] extend ; + [ >r r> set-html-stream-delegate ] keep ; : with-html-stream ( quot -- ) [ stdio [ ] change call ] with-scope ; diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index 2d597f79fe..c4faf202da 100644 --- a/library/httpd/httpd.factor +++ b/library/httpd/httpd.factor @@ -1,42 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: httpd -USE: errors -USE: httpd-responder -USE: kernel -USE: lists -USE: logging -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: threads -USE: url-encoding +USING: errors httpd-responder kernel lists logging namespaces +stdio streams strings threads url-encoding ; : httpd-log-stream ( -- stream ) #! Set httpd-log-file to save httpd log to a file. @@ -83,8 +49,7 @@ USE: url-encoding : httpd-client ( socket -- ) [ [ - stdio get "client" set log-client - read [ parse-request ] when* + stdio get log-client read [ parse-request ] when* ] with-stream ] try ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index c5cff70a5f..2dd5b5b3bb 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -1,43 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: inference -USE: errors -USE: generic -USE: interpreter -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors -USE: words -USE: hashtables -USE: prettyprint +USING: errors generic interpreter kernel lists math namespaces +strings vectors words hashtables prettyprint ; : longest-vector ( list -- length ) [ vector-length ] map [ > ] top ; @@ -140,7 +105,7 @@ SYMBOL: cloned #! Type propagation is chained. [ unswons 2dup set-value-class - [ type-propagations get ] bind assoc propagate-type + value-type-prop assoc propagate-type ] when* ; : infer-branch ( value -- namespace ) @@ -148,7 +113,7 @@ SYMBOL: cloned uncons propagate-type dup value-recursion recursive-state set copy-inference - literal-value dup infer-quot + value-literal dup infer-quot #values values-node handle-terminator ] extend ; @@ -212,7 +177,7 @@ SYMBOL: cloned dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte gensym [ dup value-recursion recursive-state set - literal-value infer-quot + value-literal infer-quot ] (with-block) drop ; : dynamic-ifte ( true false -- ) @@ -239,7 +204,7 @@ SYMBOL: cloned \ ifte [ infer-ifte ] "infer" set-word-property : vtable>list ( value -- list ) - dup value-recursion swap literal-value vector>list + dup value-recursion swap value-literal vector>list [ over ] map nip ; USE: kernel-internals diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 076832d913..4f35dda879 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -60,57 +60,46 @@ SYMBOL: d-in ! Recursive state. An alist, mapping words to labels. SYMBOL: recursive-state -GENERIC: literal-value ( value -- obj ) GENERIC: value= ( literal value -- ? ) -GENERIC: value-class ( value -- class ) GENERIC: value-class-and ( class value -- ) -GENERIC: set-value-class ( class value -- ) ! A value has the following slots in addition to those relating ! to generics above: -! An association list mapping values to [[ value class ]] pairs -SYMBOL: type-propagations +TUPLE: value literal class type-prop recursion ; +C: value ; + +TUPLE: computed delegate ; -TRAITS: computed C: computed ( class -- value ) - [ - \ value-class set - gensym \ literal-value set - type-propagations off - ] extend ; -M: computed literal-value ( value -- obj ) + over set-computed-delegate + [ set-value-class ] keep ; + +M: computed value-literal ( value -- obj ) "Cannot use a computed value literally." throw ; + M: computed value= ( literal value -- ? ) 2drop f ; -M: computed value-class ( value -- class ) - [ \ value-class get ] bind ; -M: computed value-class-and ( class value -- ) - [ \ value-class [ class-and ] change ] bind ; -M: computed set-value-class ( class value -- ) - [ \ value-class set ] bind ; -TRAITS: literal +M: computed value-class-and ( class value -- ) + [ value-class class-and ] keep set-value-class ; + +TUPLE: literal delegate ; + C: literal ( obj rstate -- value ) - [ - recursive-state set - \ literal-value set - type-propagations off - ] extend ; -M: literal literal-value ( value -- obj ) - [ \ literal-value get ] bind ; + 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 diff --git a/library/inference/types.factor b/library/inference/types.factor index 7acdc8e7b8..b6a1c377eb 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -1,44 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: inference -USE: errors -USE: generic -USE: interpreter -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors -USE: words -USE: stdio -USE: prettyprint +USING: errors generic interpreter kernel kernel-internals +lists math namespaces strings vectors words stdio prettyprint ; ! Enhanced inference of primitives relating to data types. ! Optimizes type checks and slot access. @@ -65,7 +29,7 @@ USE: prettyprint ! \ slot [ ! [ object fixnum ] ensure-d -! dataflow-drop, pop-d literal-value +! dataflow-drop, pop-d value-literal ! peek-d value-class builtin-supertypes dup length 1 = [ ! cons \ slot [ [ object ] [ object ] ] (consume/produce) ! ] [ @@ -84,7 +48,7 @@ USE: prettyprint 1 0 node-inputs [ object ] consume-d [ fixnum ] produce-d - r> peek-d [ type-propagations set ] bind + r> peek-d value-type-prop 1 0 node-outputs ] bind ] "infer" set-word-property diff --git a/library/inference/words.factor b/library/inference/words.factor index 21b1f3f50f..35d55fd2f9 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -1,44 +1,8 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! Copyright (C) 2004, 2005 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! See http://factor.sf.net/license.txt for BSD license. IN: inference -USE: errors -USE: generic -USE: interpreter -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors -USE: words -USE: hashtables -USE: parser -USE: prettyprint +USING: errors generic interpreter kernel lists math namespaces +strings vectors words hashtables parser prettyprint ; : with-dataflow ( param op [[ in# out# ]] quot -- ) #! Take input parameters, execute quotation, take output @@ -194,7 +158,7 @@ M: symbol (apply-word) ( word -- ) gensym dup [ drop pop-d dup value-recursion recursive-state set - literal-value infer-quot + value-literal infer-quot ] with-block drop ; \ call [ infer-call ] "infer" set-word-property diff --git a/library/io/ansi.factor b/library/io/ansi.factor index bd3d00dfd9..3a47e40ae6 100644 --- a/library/io/ansi.factor +++ b/library/io/ansi.factor @@ -1,41 +1,14 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: ansi -USE: lists -USE: kernel -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: presentation -USE: generic +USING: lists kernel namespaces stdio streams strings +presentation generic ; -! Some words for outputting ANSI colors. +! raps the given stream in an ANSI stream. ANSI +! streams support the following character attributes: +! bold - if not f, text is boldface. +! ansi-fg - foreground color +! ansi-bg - background color ! black 0 ! red 1 @@ -75,21 +48,11 @@ USE: generic : ansi-attr-string ( string style -- string ) [ ansi-attrs , reset , ] make-string ; -TRAITS: ansi-stream +WRAPPER: ansi-stream M: ansi-stream fwrite-attr ( string style stream -- ) - [ - [ default-style ] unless* ansi-attr-string - delegate get fwrite - ] bind ; - -C: ansi-stream ( stream -- stream ) - #! Wraps the given stream in an ANSI stream. ANSI streams - #! support the following character attributes: - #! bold - if not f, text is boldface. - #! ansi-fg - foreground color - #! ansi-bg - background color - [ delegate set ] extend ; + >r [ default-style ] unless* ansi-attr-string r> + ansi-stream-delegate fwrite ; IN: shells diff --git a/library/io/io-internals.factor b/library/io/io-internals.factor index aa0f840320..b0e55c2f83 100644 --- a/library/io/io-internals.factor +++ b/library/io/io-internals.factor @@ -76,5 +76,3 @@ BUILTIN: port 14 : blocking-copy ( in out -- ) [ add-copy-io-task (yield) ] callcc0 pending-io-error pending-io-error ; - - diff --git a/library/io/logging.factor b/library/io/logging.factor index 4627bc6a53..79e4a3881f 100644 --- a/library/io/logging.factor +++ b/library/io/logging.factor @@ -41,10 +41,9 @@ USE: unparser : log-error ( error -- ) "Error: " swap cat2 log ; -: log-client ( -- ) - "client" get [ - "Accepted connection from " swap - "client" swap hash cat2 log +: log-client ( client-stream -- ) + client-stream-host [ + "Accepted connection from " swap cat2 log ] when* ; : with-logging ( quot -- ) diff --git a/library/io/network.factor b/library/io/network.factor index 2350719fed..cbca2aab53 100644 --- a/library/io/network.factor +++ b/library/io/network.factor @@ -1,61 +1,32 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: streams -USE: io-internals -USE: errors -USE: hashtables -USE: kernel -USE: stdio -USE: strings -USE: namespaces -USE: unparser -USE: generic +USING: io-internals errors hashtables kernel stdio strings +namespaces unparser generic ; -TRAITS: server +TUPLE: server port ; GENERIC: accept M: server fclose ( stream -- ) - [ "socket" get close-port ] bind ; + server-port close-port ; C: server ( port -- stream ) #! Starts listening on localhost:port. Returns a stream that #! you can close with fclose, and accept connections from #! with accept. No other stream operations are supported. - [ server-socket "socket" set ] extend ; + [ >r server-socket r> set-server-port ] keep ; -: ( host port in out -- stream ) - [ ":" swap unparse cat3 "client" set ] extend ; +TUPLE: client-stream delegate host ; + +C: client-stream ( host port in out -- stream ) + #! fflush yields until connection is established. + [ >r r> set-client-stream-delegate ] keep + [ >r ":" swap unparse cat3 r> set-client-stream-host ] keep + dup fflush ; : ( host port -- stream ) - #! fflush yields until connection is established. - 2dup client-socket dup fflush ; + 2dup client-socket ; M: server accept ( server -- client ) #! Accept a connection from a server socket. - "socket" swap hash blocking-accept ; - + server-port blocking-accept ; diff --git a/library/io/stdio.factor b/library/io/stdio.factor index df04ef1a40..bf63838666 100644 --- a/library/io/stdio.factor +++ b/library/io/stdio.factor @@ -1,38 +1,7 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: stdio -USE: errors -USE: kernel -USE: lists -USE: namespaces -USE: streams -USE: generic -USE: strings +USING: errors kernel lists namespaces streams generic strings ; SYMBOL: stdio @@ -56,24 +25,14 @@ SYMBOL: stdio : with-string ( quot -- str ) #! Execute a quotation, and push a string containing all #! text printed by the quotation. - 1024 [ + 1024 [ 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 [ - stdio set call - ] with-scope ; inline diff --git a/library/io/stream-impl.factor b/library/io/stream-impl.factor index a69eb54885..55db952403 100644 --- a/library/io/stream-impl.factor +++ b/library/io/stream-impl.factor @@ -1,68 +1,36 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: stdio DEFER: stdio IN: streams -USE: io-internals -USE: errors -USE: hashtables -USE: kernel -USE: stdio -USE: strings -USE: namespaces -USE: generic +USING: io-internals errors hashtables kernel stdio strings +namespaces generic ; -TRAITS: fd-stream +TUPLE: fd-stream in out ; M: fd-stream fwrite-attr ( str style stream -- ) - [ drop "out" get blocking-write ] bind ; + nip fd-stream-out blocking-write ; M: fd-stream freadln ( stream -- str ) - [ "in" get dup [ blocking-read-line ] when ] bind ; + fd-stream-in dup [ blocking-read-line ] when ; M: fd-stream fread# ( count stream -- str ) - [ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ; + fd-stream-in dup [ blocking-read# ] [ nip ] ifte ; M: fd-stream fflush ( stream -- ) - [ "out" get [ blocking-flush ] when* ] bind ; + fd-stream-out [ blocking-flush ] when* ; M: fd-stream fauto-flush ( stream -- ) drop ; -M: fd-stream fclose ( -- ) - [ - "out" get [ dup blocking-flush close-port ] when* - "in" get [ close-port ] when* - ] bind ; +M: fd-stream fclose ( stream -- ) + dup fd-stream-out [ dup blocking-flush close-port ] when* + fd-stream-in [ close-port ] when* ; C: fd-stream ( in out -- stream ) - [ "out" set "in" set ] extend ; + [ set-fd-stream-out ] keep + [ set-fd-stream-in ] keep ; : ( path -- stream ) t f open-file ; @@ -77,7 +45,7 @@ C: fd-stream ( in out -- stream ) #! Copy the contents of the fd-stream 'from' to the #! fd-stream 'to'. Use fcopy; this word does not close #! streams. - "out" swap hash >r "in" swap hash r> blocking-copy ; + fd-stream-out >r fd-stream-in r> blocking-copy ; : fcopy ( from to -- ) #! Copy the contents of the fd-stream 'from' to the diff --git a/library/io/stream.factor b/library/io/stream.factor index c81c430413..834accfbeb 100644 --- a/library/io/stream.factor +++ b/library/io/stream.factor @@ -1,37 +1,9 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: stdio +DEFER: stdio IN: streams -USE: errors -USE: kernel -USE: namespaces -USE: strings -USE: generic -USE: lists +USING: errors kernel namespaces strings generic lists ; GENERIC: fflush ( stream -- ) GENERIC: fauto-flush ( stream -- ) @@ -52,46 +24,32 @@ GENERIC: fclose ( stream -- ) [ "\n" swap fwrite ] keep fauto-flush ; -TRAITS: string-output-stream +! A stream that builds a string of all text written to it. +TUPLE: string-output buf ; -M: string-output-stream fwrite-attr ( string style stream -- ) - [ drop "buf" get sbuf-append ] bind ; +M: string-output fwrite-attr ( string style stream -- ) + nip string-output-buf sbuf-append ; -M: string-output-stream fclose ( stream -- ) - drop ; - -M: string-output-stream fflush ( stream -- ) - drop ; - -M: string-output-stream fauto-flush ( stream -- ) - drop ; +M: string-output fclose ( stream -- ) drop ; +M: string-output fflush ( stream -- ) drop ; +M: string-output fauto-flush ( stream -- ) drop ; : stream>str ( stream -- string ) #! Returns the string written to the given string output #! stream. - [ "buf" get ] bind sbuf>str ; + string-output-buf sbuf>str ; -C: string-output-stream ( size -- stream ) +C: string-output ( size -- stream ) #! Creates a new stream for writing to a string buffer. - [ "buf" set ] extend ; + [ >r 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 [ stdio set ] extend r> + set-wrapper-stream-scope + ] keep ; diff --git a/library/primitives.factor b/library/primitives.factor index 3a9f4d3b80..ce1c816826 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -185,6 +185,8 @@ hashtables ; [ [ [ number ] [ hashtable ] ] ] [ [ [ number ] [ array ] ] ] [ [ [ number ] [ tuple ] ] ] + [ >array [ [ object ] [ array ] ] ] + [ >tuple [ [ object ] [ tuple ] ] ] ] [ 2unlist dup string? [ "stack-effect" set-word-property diff --git a/library/test/benchmark/strings.factor b/library/test/benchmark/strings.factor index 6308741eae..f9aac6a36c 100644 --- a/library/test/benchmark/strings.factor +++ b/library/test/benchmark/strings.factor @@ -21,4 +21,4 @@ USE: compiler : string-benchmark ( n -- ) "abcdef" 10 [ 2dup string-step ] times 2drop ; compiled -[ ] [ 1000000 string-benchmark ] unit-test +[ ] [ 400000 string-benchmark ] unit-test diff --git a/library/test/generic.factor b/library/test/generic.factor index 7b039e6cd3..ea3d5bd9f6 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -10,58 +10,6 @@ USE: lists USE: vectors USE: alien -TRAITS: test-traits -C: test-traits ; - -[ t ] [ test-traits? ] unit-test -[ f ] [ "hello" test-traits? ] unit-test -[ f ] [ 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 ] [ foo ] unit-test -[ 13 ] [ foo ] unit-test - -TRAITS: quux -C: quux ; - -M: quux foo "foo" swap hash ; - -[ - "Hi" -] [ - [ - "Hi" "foo" set - ] extend foo -] unit-test - -TRAITS: ctr-test -C: ctr-test [ 5 "x" set ] extend ; - -[ - 5 -] [ - [ "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 ] [ super ] unit-test - GENERIC: class-of M: fixnum class-of drop "fixnum" ; @@ -140,8 +88,6 @@ M: very-funny gooey sq ; [ number ] [ number object class-and ] unit-test [ number ] [ object number class-and ] unit-test -[ t ] [ del1 builtin-supertypes [ integer? ] all? ] unit-test - [ cons ] [ [ 1 2 ] class ] unit-test [ t ] [ \ generic \ compound class< ] unit-test diff --git a/library/test/stream.factor b/library/test/stream.factor index e864c6d706..96f57482d1 100644 --- a/library/test/stream.factor +++ b/library/test/stream.factor @@ -7,34 +7,3 @@ USE: generic USE: kernel [ "xyzzy" ] [ [ "xyzzy" write ] with-string ] unit-test - -TRAITS: xyzzy-stream - -M: xyzzy-stream fwrite-attr ( str style stream -- ) - [ - drop "<" delegate get fwrite - delegate get fwrite - ">" delegate get fwrite - ] bind ; - -M: xyzzy-stream fclose ( stream -- ) - drop ; - -M: xyzzy-stream fflush ( stream -- ) - drop ; - -M: xyzzy-stream fauto-flush ( stream -- ) - drop ; - -C: xyzzy-stream ( stream -- stream ) - [ delegate set ] extend ; - -[ - "" -] [ - [ - stdio get [ - "xyzzy" write - ] with-stream - ] with-string -] unit-test diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 2218c6d12b..29fe864382 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -157,9 +157,7 @@ M: object error. ( error -- ) : print-error ( error -- ) #! Print the error. [ - "! " [ - in-parser? [ parse-dump ] when error. - ] with-prefix + in-parser? [ parse-dump ] when error. ] [ flush-error-handler ] catch ; diff --git a/library/tools/jedit-wire.factor b/library/tools/jedit-wire.factor index 58daed042b..160dc59553 100644 --- a/library/tools/jedit-wire.factor +++ b/library/tools/jedit-wire.factor @@ -37,6 +37,7 @@ USE: streams USE: strings USE: words USE: generic +USE: listener ! Wire protocol for jEdit to evaluate Factor code. ! Packets are of the form: @@ -46,7 +47,7 @@ USE: generic ! ! jEdit sends a packet with code to eval, it receives the output ! captured with with-string. -USE: listener + : write-packet ( string -- ) dup str-length write-big-endian-32 write flush ; @@ -77,19 +78,22 @@ USE: listener dup str-length write-big-endian-32 write ; -TRAITS: jedit-stream +TUPLE: jedit-stream delegate ; M: jedit-stream freadln ( stream -- str ) + wrapper-stream-scope [ CHAR: r write flush read-big-endian-32 read# ] bind ; M: jedit-stream fwrite-attr ( str style stream -- ) + wrapper-stream-scope [ [ default-style ] unless* jedit-write-attr ] bind ; M: jedit-stream fflush ( stream -- ) + wrapper-stream-scope [ CHAR: f write flush ] bind ; C: jedit-stream ( stream -- stream ) - [ dup delegate set stdio set ] extend ; + [ >r r> set-jedit-stream-delegate ] keep ; : stream-server ( -- ) #! Execute this in the inferior Factor. diff --git a/library/tools/telnetd.factor b/library/tools/telnetd.factor index 95e146993b..b6432640de 100644 --- a/library/tools/telnetd.factor +++ b/library/tools/telnetd.factor @@ -1,47 +1,11 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: telnetd -USE: errors -USE: listener -USE: kernel -USE: logging -USE: namespaces -USE: stdio -USE: streams -USE: threads -USE: parser +USING: errors listener kernel logging namespaces stdio streams +threads parser ; : telnet-client ( socket -- ) - dup [ - "client" set - log-client - listener - ] with-stream ; + dup [ log-client listener ] with-stream ; : telnet-connection ( socket -- ) [ telnet-client ] in-thread drop ; diff --git a/library/ui/console.factor b/library/ui/console.factor index 1b97d2bfaf..526507a0c2 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -199,47 +199,37 @@ SYMBOL: redraw-console ! The console stream -! Restoring this continuation returns to the -! top-level console event loop. -SYMBOL: redraw-continuation - ! Restoring this continuation with a string on the stack returns ! to the caller of freadln. SYMBOL: input-continuation -TRAITS: console-stream +TUPLE: console-stream console redraw-continuation ; C: console-stream ( console console-continuation -- stream ) - [ - redraw-continuation set - console set - ] extend ; + [ set-console-stream-redraw-continuation ] keep + [ set-console-stream-console ] keep ; M: console-stream fflush ( stream -- ) fauto-flush ; M: console-stream fauto-flush ( stream -- ) - [ - console get [ redraw-console on ] bind - ] bind ; + console-stream-console [ redraw-console on ] bind ; M: console-stream freadln ( stream -- line ) [ - [ - console get [ input-continuation set ] bind - redraw-continuation get dup [ - 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 ; @@ -375,7 +365,6 @@ M: alien handle-event ( event -- ? ) check-event [ console-loop ] when ; : console-quit ( -- ) - redraw-continuation off input-continuation get [ f swap call ] when* SDL_Quit ; diff --git a/native/array.c b/native/array.c index d7e7b97510..37029970ba 100644 --- a/native/array.c +++ b/native/array.c @@ -31,6 +31,11 @@ void primitive_array(void) dpush(tag_object(array(ARRAY_TYPE,capacity,F))); } +void primitive_to_array(void) +{ + type_check(ARRAY_TYPE,dpeek()); +} + void primitive_tuple(void) { F_FIXNUM capacity = to_fixnum(dpop()); @@ -40,6 +45,11 @@ void primitive_tuple(void) dpush(tag_object(array(TUPLE_TYPE,capacity,F))); } +void primitive_to_tuple(void) +{ + type_check(TUPLE_TYPE,dpeek()); +} + F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) { /* later on, do an optimization: if end of array is here, just grow */ diff --git a/native/array.h b/native/array.h index 7f048c0f0f..5f28a97b02 100644 --- a/native/array.h +++ b/native/array.h @@ -13,7 +13,9 @@ INLINE F_ARRAY* untag_array(CELL tagged) F_ARRAY* allot_array(CELL type, CELL capacity); F_ARRAY* array(CELL type, CELL capacity, CELL fill); void primitive_array(void); +void primitive_to_array(void); void primitive_tuple(void); +void primitive_to_tuple(void); F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill); void primitive_grow_array(void); F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); diff --git a/native/debug.c b/native/debug.c index 1c1b3ebe14..5d4f793d2a 100644 --- a/native/debug.c +++ b/native/debug.c @@ -15,6 +15,9 @@ bool equals(CELL obj1, CELL obj2) CELL assoc(CELL alist, CELL key) { + if(alist == F) + return F; + if(TAG(alist) != CONS_TYPE) { fprintf(stderr,"Not an alist: %ld\n",alist); @@ -36,6 +39,38 @@ CELL assoc(CELL alist, CELL key) } } +CELL hash(CELL hash, CELL key) +{ + if(type_of(hash) != HASHTABLE_TYPE) + { + fprintf(stderr,"Not a hash: %ld\n",hash); + return F; + } + + { + int i; + + CELL array = ((F_HASHTABLE*)UNTAG(hash))->array; + F_ARRAY* a; + + if(type_of(array) != ARRAY_TYPE) + { + fprintf(stderr,"Not an array: %ld\n",hash); + return F; + } + + a = untag_array(array); + + for(i = 0; i < untag_fixnum_fast(a->capacity); i++) + { + CELL value = assoc(get(AREF(a,i)),key); + if(value != F) + return value; + } + + return F; + } +} void print_cons(CELL cons) { fprintf(stderr,"[ "); @@ -59,7 +94,7 @@ void print_cons(CELL cons) void print_word(F_WORD* word) { - CELL name = assoc(word->plist,tag_object(from_c_string("name"))); + CELL name = hash(word->plist,tag_object(from_c_string("name"))); if(type_of(name) == STRING_TYPE) fprintf(stderr,"%s",to_c_string(untag_string(name))); else @@ -83,6 +118,9 @@ void print_obj(CELL obj) { switch(type_of(obj)) { + case FIXNUM_TYPE: + fprintf(stderr,"%d",untag_fixnum_fast(obj)); + break; case CONS_TYPE: print_cons(obj); break; diff --git a/native/primitives.c b/native/primitives.c index 3a426e454c..7a36c0f14c 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -176,7 +176,9 @@ void* primitives[] = { primitive_grow_array, primitive_hashtable, primitive_array, - primitive_tuple + primitive_tuple, + primitive_to_array, + primitive_to_tuple }; CELL primitive_to_xt(CELL primitive)