Merge branch 'master' of git://factorcode.org/git/factor

core/assocs/assocs-tests.factor

@@ -99,8 +99,8 @@ unit-test
         3
         H{ } clone
         2 [
-            2dup [ , f ] cache
+            2dup [ , f ] cache drop
         ] times
         2drop
-    ] make
+    ] { } make
 ] unit-test

core/bootstrap/primitives.factor

@@ -324,14 +324,20 @@ define-builtin
     }
 } define-builtin
 
-"tuple" "kernel" create {
+"tuple" "kernel" create { } define-builtin
+
+"tuple" "kernel" lookup
+{
     {
-        { "tuple-layout" "tuples.private" }
+        { "object" "kernel" }
-        "layout"
+        "delegate"
-        { "tuple-layout" "tuples.private" }
+        { "delegate" "kernel" }
-        f
+        { "set-delegate" "kernel" }
     }
-} define-builtin
+}
+define-tuple-slots
+
+"tuple" "kernel" lookup define-tuple-layout
 
 ! Define general-t type, which is any object that is not f.
 "general-t" "kernel" create

core/classes/algebra/algebra-docs.factor

@@ -30,7 +30,7 @@ HELP: class-types
 { $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
 
 HELP: class<
-{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
+{ $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }
 { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
 { $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
 

core/classes/classes.factor

@@ -57,6 +57,9 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     #! Output f for non-classes to work with algebra code
     dup class? [ "superclass" word-prop ] [ drop f ] if ;
 
+: superclasses ( class -- supers )
+    [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
+
 : members ( class -- seq )
     #! Output f for non-classes to work with algebra code
     dup class? [ "members" word-prop ] [ drop f ] if ;

core/compiler/tests/templates.factor

@@ -81,8 +81,8 @@ unit-test
     -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call
 ] unit-test
 
-[ 2 ] [
+[ 1 ] [
-    SBUF" " [ 2 slot 2 [ slot ] keep ] compile-call nip
+    SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
 ] unit-test
 
 ! Test slow shuffles

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -489,7 +489,7 @@ IN: cpu.ppc.intrinsics
     ! Store tagged ptr in reg
     "tuple" get tuple %store-tagged
 ] H{
-    { +input+ { { [ tuple-layout? ] "layout" } }
+    { +input+ { { [ tuple-layout? ] "layout" } } }
     { +scratch+ { { f "tuple" } } }
     { +output+ { "tuple" } }
 } define-intrinsic

core/io/encodings/encodings-docs.factor

@@ -19,20 +19,23 @@ HELP: <encoder>
 { $values { "stream" "an output stream" }
     { "encoding" "an encoding descriptor" }
     { "newstream" "an encoded output stream" } }
-{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
+{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
+$low-level-note ;
 
 HELP: <decoder>
 { $values { "stream" "an input stream" }
     { "encoding" "an encoding descriptor" }
     { "newstream" "an encoded output stream" } }
-{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
+{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
+$low-level-note ;
 
 HELP: <encoder-duplex>
 { $values { "stream-in" "an input stream" }
     { "stream-out" "an output stream" }
     { "encoding" "an encoding descriptor" }
     { "duplex" "an encoded duplex stream" } }
-{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." } ;
+{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." }
+$low-level-note ;
 
 { <encoder> <decoder> <encoder-duplex> } related-words
 
@@ -58,12 +61,14 @@ ARTICLE: "encodings-protocol" "Encoding protocol"
 HELP: decode-char
 { $values { "stream" "an underlying input stream" }
     { "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
-{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
+{ $contract "Reads a single code point from the underlying stream, interpreting it by the encoding." }
+$low-level-note ;
 
 HELP: encode-char
 { $values { "char" "a character" }
     { "stream" "an underlying output stream" }
     { "encoding" "an encoding descriptor" } }
-{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ;
+{ $contract "Writes the code point in the encoding to the underlying stream given." }
+$low-level-note ;
 
 { encode-char decode-char } related-words

core/io/files/files.factor

@@ -264,12 +264,10 @@ DEFER: copy-tree-into
     prepend-path ;
 
 : temp-directory ( -- path )
-    "temp" resource-path
+    "temp" resource-path dup make-directories ;
-    dup exists? not
-      [ dup make-directory ]
-    when ;
 
-: temp-file ( name -- path ) temp-directory prepend-path ;
+: temp-file ( name -- path )
+    temp-directory prepend-path ;
 
 M: object normalize-pathname ( path -- path' )
     "resource:" ?head [

core/mirrors/mirrors-tests.factor

@@ -5,7 +5,7 @@ TUPLE: foo bar baz ;
 
 C: <foo> foo
 
-[ { "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
+[ { "delegate" "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
 
 [ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
 

core/mirrors/mirrors.factor

@@ -5,13 +5,11 @@ arrays classes slots slots.private tuples math vectors
 quotations sorting prettyprint ;
 IN: mirrors
 
-GENERIC: object-slots ( obj -- seq )
+: all-slots ( class -- slots )
+    superclasses [ "slots" word-prop ] map concat ;
 
-M: object object-slots class "slots" word-prop ;
+: object-slots ( obj -- seq )
-
+    class all-slots ;
-M: tuple object-slots
-    dup class "slots" word-prop
-    swap delegate [ 1 tail-slice ] unless ;
 
 TUPLE: mirror object slots ;
 

core/tuples/tuples-docs.factor

@@ -191,7 +191,7 @@ HELP: define-tuple-predicate
 $low-level-note ;
 
 HELP: redefine-tuple-class
-{ $values { "class" class } { "superclass" class } { "newslots" "a sequence of strings" } }
+{ $values { "class" class } { "superclass" class } { "slots" "a sequence of strings" } }
 { $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
 $nl
 "If the class is not a tuple class word, this word does nothing." }

core/tuples/tuples-tests.factor

@@ -246,6 +246,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
 
 ! Inheritance
 TUPLE: computer cpu ram ;
+C: <computer> computer
 
 [ "TUPLE: computer cpu ram ;" ] [
     [ \ computer see ] with-string-writer string-lines second
@@ -264,11 +265,23 @@ C: <laptop> laptop
 [ t ] [ "laptop" get computer? ] unit-test
 [ t ] [ "laptop" get tuple? ] unit-test
 
+[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
+[ 128 ] [ "laptop" get ram>> ] unit-test
+[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
+
+[ laptop ] [
+    "laptop" get tuple-layout
+    dup layout-echelon swap
+    layout-superclasses nth
+] unit-test
+
 [ "TUPLE: laptop < computer battery ;" ] [
     [ \ laptop see ] with-string-writer string-lines second
 ] unit-test
 
-TUPLE: server < computer rackmount? ;
+[ { tuple computer laptop } ] [ laptop superclasses ] unit-test
+
+TUPLE: server < computer rackmount ;
 C: <server> server
 
 [ t ] [ server tuple-class? ] unit-test
@@ -276,11 +289,15 @@ C: <server> server
 [ t ] [ server computer class< ] unit-test
 [ t ] [ server computer classes-intersect? ] unit-test
 
-[ ] [ "Pentium" 128 "1U" <server> "server" set ] unit-test
+[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
 [ t ] [ "server" get server? ] unit-test
 [ t ] [ "server" get computer? ] unit-test
 [ t ] [ "server" get tuple? ] unit-test
 
+[ "PowerPC" ] [ "server" get cpu>> ] unit-test
+[ 64 ] [ "server" get ram>> ] unit-test
+[ "1U" ] [ "server" get rackmount>> ] unit-test
+
 [ f ] [ "server" get laptop? ] unit-test
 [ f ] [ "laptop" get server? ] unit-test
 
@@ -288,7 +305,10 @@ C: <server> server
 [ f ] [ laptop server class< ] unit-test
 [ f ] [ laptop server classes-intersect? ] unit-test
 
-[ "TUPLE: server < computer rackmount? ;" ] [
+[ f ] [ 1 2 <computer> laptop? ] unit-test
+[ f ] [ \ + server? ] unit-test
+
+[ "TUPLE: server < computer rackmount ;" ] [
     [ \ server see ] with-string-writer string-lines second
 ] unit-test
 

core/tuples/tuples.factor

@@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel
 kernel.private math namespaces sequences sequences.private
 strings vectors words quotations memory combinators generic
 classes classes.private slots.deprecated slots.private slots
-compiler.units ;
+compiler.units math.private ;
 IN: tuples
 
 M: tuple delegate 2 slot ;
@@ -17,6 +17,12 @@ ERROR: no-tuple-class class ;
 
 <PRIVATE
 
+GENERIC: tuple-layout ( object -- layout )
+
+M: class tuple-layout "layout" word-prop ;
+
+M: tuple tuple-layout 1 slot ;
+
 : tuple-size tuple-layout layout-size ; inline
 
 PRIVATE>
@@ -30,7 +36,7 @@ PRIVATE>
     [ layout-size swap [ array-nth ] curry map ] keep
     layout-class add* ;
 
-: >tuple ( sequence -- tuple )
+: >tuple ( seq -- tuple )
     dup first tuple-layout <tuple> [
         >r 1 tail-slice dup length r>
         [ tuple-size min ] keep
@@ -49,33 +55,56 @@ PRIVATE>
         2drop f
     ] if ;
 
-M: tuple-class tuple-layout "layout" word-prop ;
+! Predicate generation. We optimize at the expense of simplicity
+
+: (tuple-predicate-quot) ( class -- quot )
+    #! 4 slot == layout-superclasses
+    #! 5 slot == layout-echelon
+    [
+        [ 1 slot dup 5 slot ] %
+        dup tuple-layout layout-echelon ,
+        [ fixnum>= ] %
+        [
+            dup tuple-layout layout-echelon ,
+            [ swap 4 slot array-nth ] %
+            literalize ,
+            [ eq? ] %
+        ] [ ] make ,
+        [ drop f ] ,
+        \ if ,
+    ] [ ] make ;
+
+: tuple-predicate-quot ( class -- quot )
+    [
+        [ dup tuple? ] %
+        (tuple-predicate-quot) ,
+        [ drop f ] ,
+        \ if ,
+    ] [ ] make ;
 
 : define-tuple-predicate ( class -- )
-    dup tuple-layout
+    dup tuple-predicate-quot define-predicate ;
-    [ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry
-    define-predicate ;
 
-: delegate-slot-spec
+: superclass-size ( class -- n )
-    T{ slot-spec f
+    superclasses 1 head-slice*
-        object
+    [ "slot-names" word-prop length ] map sum ;
-        "delegate"
+
-        2
+: generate-tuple-slots ( class slots -- slot-specs slot-names )
-        delegate
+    over superclass-size 2 + simple-slots
-        set-delegate
+    dup [ slot-spec-name ] map ;
-    } ;
 
 : define-tuple-slots ( class slots -- )
-    dupd 3 simple-slots
+    dupd generate-tuple-slots
-    2dup [ slot-spec-name ] map "slot-names" set-word-prop
+    >r dupd "slots" set-word-prop
-    2dup delegate-slot-spec add* "slots" set-word-prop
+    r> dupd "slot-names" set-word-prop
-    2dup define-slots
+    dup "slots" word-prop 2dup define-slots define-accessors ;
-    define-accessors ;
+
+: make-tuple-layout ( class -- layout )
+    dup superclass-size over "slot-names" word-prop length +
+    over superclasses dup length 1- <tuple-layout> ;
 
 : define-tuple-layout ( class -- )
-    dup
+    dup make-tuple-layout "layout" set-word-prop ;
-    dup "slot-names" word-prop length 1+ { } 0 <tuple-layout>
-    "layout" set-word-prop ;
 
 : removed-slots ( class newslots -- seq )
     swap "slot-names" word-prop seq-diff ;

extra/help/handbook/handbook.factor

@@ -178,9 +178,16 @@ ARTICLE: "encodings-introduction" "An introduction to encodings"
 "Not all encodings can represent all Unicode code points, but Unicode can represent basically everything that exists in modern encodings. Some encodings are language-specific, and some can represent everything in Unicode. Though the world is moving toward Unicode and UTF-8, the reality today is that there are several encodings which must be taken into account." $nl
 "Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } ", " { $link ascii } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl
 "Constructors for streams which deal with bytes usually take an encoding as an explicit parameter. For example, to open a text file for reading whose contents are in UTF-8, use the following"
-{ $code "\"filename\" utf8 <file-reader>" }
+{ $code "\"file.txt\" utf8 <file-reader>" }
 "If there is an error in the encoded stream, a replacement character (0xFFFD) will be inserted. To throw an exception upon error, use a strict encoding as follows"
-{ $code "\"filename\" utf8 strict <file-reader>" } ;
+{ $code "\"file.txt\" utf8 strict <file-reader>" }
+"In a similar way, encodings can be specified when opening a file for writing."
+{ $code "\"file.txt\" ascii <file-writer>" }
+"An encoding is also needed for some words that don't return streams, such as " { $link file-contents } ", for example"
+{ $code "\"file.txt\" utf16 file-contents" }
+"Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text."
+$nl
+"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ;
 
 ARTICLE: "io" "Input and output"
 { $heading "Streams" }

extra/http/server/static/static.factor

@@ -39,7 +39,9 @@ TUPLE: file-responder root hook special ;
     [ 2drop <304> ] [ file-responder get hook>> call ] if ;
 
 : serving-path ( filename -- filename )
-    "" or file-responder get root>> prepend-path ;
+    file-responder get root>> right-trim-separators
+    "/"
+    rot "" or left-trim-separators 3append ;
 
 : serve-file ( filename -- response )
     dup mime-type

extra/inverse/inverse.factor

@@ -1,7 +1,7 @@
 USING: kernel words inspector slots quotations sequences assocs
 math arrays inference effects shuffle continuations debugger
 tuples namespaces vectors bit-arrays byte-arrays strings sbufs
-math.functions macros sequences.private combinators ;
+math.functions macros sequences.private combinators mirrors ;
 IN: inverse
 
 TUPLE: fail ;
@@ -191,7 +191,7 @@ MACRO: undo ( quot -- ) [undo] ;
     "predicate" word-prop [ dupd call assure ] curry ;
 
 : slot-readers ( class -- quot )
-    "slots" word-prop 1 tail ! tail gets rid of delegate
+    all-slots 1 tail ! tail gets rid of delegate
     [ slot-spec-reader 1quotation [ keep ] curry ] map concat
     [ ] like [ drop ] compose ;
 

extra/io/encodings/8-bit/8-bit-docs.factor

@@ -24,14 +24,18 @@ ARTICLE: "io.encodings.8-bit" "8-bit encodings"
 { $subsection windows-1252 }
 { $subsection ebcdic }
 { $subsection mac-roman }
-"Other encodings can be defined using the following utility"
+"Words used in defining these"
+{ $subsection 8-bit }
 { $subsection define-8-bit-encoding } ;
 
 ABOUT: "io.encodings.8-bit"
 
+HELP: 8-bit
+{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ;
+
 HELP: define-8-bit-encoding
 { $values { "name" "a string" } { "path" "a path" } }
-{ $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file should be in a similar format to those at ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } ;
+{ $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
 
 HELP: latin1
 { $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." } 

extra/io/encodings/8-bit/8-bit.factor

@@ -3,7 +3,7 @@
 USING: math.parser arrays io.encodings sequences kernel
 assocs hashtables io.encodings.ascii combinators.cleave
 generic parser tuples words io io.files splitting namespaces
-classes quotations math compiler.units ;
+math compiler.units accessors ;
 IN: io.encodings.8-bit
 
 <PRIVATE
@@ -38,9 +38,9 @@ IN: io.encodings.8-bit
     2dup swap length <= [ tail ] [ drop ] if ;
 
 : process-contents ( lines -- assoc )
-    [ "#" split first ] map
+    [ "#" split1 drop ] map
     [ empty? not ] subset
-    [ "\t " split 2 head [ 2 tail-if hex> ] map ] map ;
+    [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
 
 : byte>ch ( assoc -- array )
     256 replacement-char <array>
@@ -53,39 +53,32 @@ IN: io.encodings.8-bit
     ascii file-lines process-contents
     [ byte>ch ] [ ch>byte ] bi ;
 
-: empty-tuple-class ( string -- class )
+TUPLE: 8-bit name decode encode ;
-    "io.encodings.8-bit" create
-    dup tuple { } define-tuple-class ;
 
-: data-quot ( class word data -- quot )
+: encode-8-bit ( char stream assoc -- )
-    >r [ word-name ] 2apply "/" swap 3append
+    swapd at* [ encode-error ] unless swap stream-write1 ;
-    "/data" append in get create dup 1quotation swap r>
-    1quotation define ;
 
-: method-with-data ( class data word quot -- )
+M: 8-bit encode-char
-    >r swap >r 2dup r> data-quot r>
+    encode>> encode-8-bit ;
-    compose >r create-method r> define ;
 
-: encode-8-bit ( char stream encoding assoc -- )
+: decode-8-bit ( stream array -- char/f )
-    nip swapd at* [ encode-error ] unless swap stream-write1 ;
+    swap stream-read1 dup
-
-: define-encode-char ( class assoc -- )
-    \ encode-char [ encode-8-bit ] method-with-data ;
-
-: decode-8-bit ( stream encoding array -- char/f )
-    nip swap stream-read1
     [ swap nth [ replacement-char ] unless* ]
-    [ drop f ] if* ;
+    [ nip ] if ;
 
-: define-decode-char ( class array -- )
+M: 8-bit decode-char
-    \ decode-char [ decode-8-bit ] method-with-data ;
+    decode>> decode-8-bit ;
 
-: 8-bit-methods ( class byte>ch ch>byte -- )
+: make-8-bit ( word byte>ch ch>byte -- )
-    >r over r> define-encode-char define-decode-char ;
+    [ 8-bit construct-boa ] 2curry dupd curry define ;
 
 : define-8-bit-encoding ( name path -- )
-    >r empty-tuple-class r> parse-file 8-bit-methods ;
+    >r in get create r> parse-file make-8-bit ;
 
 PRIVATE>
 
-[ mappings [ full-path define-8-bit-encoding ] assoc-each ] with-compilation-unit
+[
+    "io.encodings.8-bit" in [
+        mappings [ full-path define-8-bit-encoding ] assoc-each
+    ] with-variable
+] with-compilation-unit

extra/io/encodings/utf16/utf16-docs.factor

@@ -11,15 +11,19 @@ ARTICLE: "io.encodings.utf16" "UTF-16"
 ABOUT: "io.encodings.utf16"
 
 HELP: utf16le
-{ $class-description "The encoding descriptor for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ;
+{ $class-description "The encoding descriptor for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
 
 HELP: utf16be
-{ $class-description "The encoding descriptor for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ;
+{ $class-description "The encoding descriptor for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
 
 HELP: utf16
-{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." } ;
+{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
 
 HELP: utf16n
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings in of wide_t*." } ;
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings in of wide_t*." }
+{ $see-also "encodings-introduction" } ;
 
 { utf16 utf16le utf16be utf16n } related-words

extra/io/windows/files/files.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.files io.windows kernel
+USING: alien.c-types io.backend io.files io.windows kernel
 math windows windows.kernel32 combinators.cleave
 windows.time calendar combinators math.functions
 sequences namespaces words symbols ;

extra/peg/parsers/parsers.factor

@@ -3,10 +3,11 @@
 USING: kernel sequences strings namespaces math assocs shuffle 
      vectors arrays combinators.lib math.parser match
      unicode.categories sequences.deep peg peg.private 
-     peg.search math.ranges words ;
+     peg.search math.ranges words memoize ;
 IN: peg.parsers
 
 TUPLE: just-parser p1 ;
+M: just-parser equal? 2drop f ;
 
 : just-pattern
   [
@@ -19,7 +20,7 @@ TUPLE: just-parser p1 ;
 M: just-parser (compile) ( parser -- quot )
   just-parser-p1 compiled-parser just-pattern curry ;
 
-: just ( parser -- parser )
+MEMO: just ( parser -- parser )
   just-parser construct-boa ;
 
 : 1token ( ch -- parser ) 1string token ;
@@ -47,10 +48,10 @@ PRIVATE>
 
 PRIVATE>
 
-: exactly-n ( parser n -- parser' )
+MEMO: exactly-n ( parser n -- parser' )
   swap <repetition> seq ;
 
-: at-most-n ( parser n -- parser' )
+MEMO: at-most-n ( parser n -- parser' )
   dup zero? [
     2drop epsilon
   ] [
@@ -58,15 +59,15 @@ PRIVATE>
     -rot 1- at-most-n 2choice
   ] if ;
 
-: at-least-n ( parser n -- parser' )
+MEMO: at-least-n ( parser n -- parser' )
   dupd exactly-n swap repeat0 2seq
   [ flatten-vectors ] action ;
 
-: from-m-to-n ( parser m n -- parser' )
+MEMO: from-m-to-n ( parser m n -- parser' )
   >r [ exactly-n ] 2keep r> swap - at-most-n 2seq
   [ flatten-vectors ] action ;
 
-: pack ( begin body end -- parser )
+MEMO: pack ( begin body end -- parser )
   >r >r hide r> r> hide 3seq [ first ] action ;
 
 : surrounded-by ( parser begin end -- parser' )
@@ -83,7 +84,7 @@ PRIVATE>
     [ CHAR: " = ] satisfy hide ,
     [ CHAR: " = not ] satisfy repeat0 ,
     [ CHAR: " = ] satisfy hide ,
-  ] { } make seq [ first >string ] action ;
+  ] seq* [ first >string ] action ;
 
 : (range-pattern) ( pattern -- string )
   #! Given a range pattern, produce a string containing

extra/peg/peg-docs.factor

@@ -11,7 +11,36 @@ HELP: parse
 }
 { $description 
     "Given the input string, parse it using the given parser. The result is a <parse-result> object if "
-    "the parse was successful, otherwise it is f." } ;
+    "the parse was successful, otherwise it is f." } 
+{ $see-also compile with-packrat } ;
+
+HELP: with-packrat
+{ $values 
+  { "quot" "a quotation with stack effect ( input -- result )" } 
+  { "result" "the result of the quotation" } 
+}
+{ $description 
+    "Calls the quotation with a packrat cache in scope. Usually the quotation will "
+    "call " { $link parse } " or call a word produced by " { $link compile } "."
+    "The cache is used to avoid the possible exponential time performace that pegs "
+    "can have, instead giving linear time at the cost of increased memory usage."  } 
+{ $see-also compile parse } ;
+
+HELP: compile
+{ $values 
+  { "parser" "a parser" } 
+  { "word" "a word" } 
+}
+{ $description 
+    "Compile the parser to a word. The word will have stack effect ( input -- result )."
+    "The mapping from parser to compiled word is kept in a cache. If you later change "
+    "the definition of a parser you'll need to clear this cache with " 
+    { $link reset-compiled-parsers } " before using " { $link compile } " on that parser again." } 
+{ $see-also compile with-packrat reset-compiled-parsers } ;
+
+HELP: reset-compiled-parsers
+{ $description 
+    "Reset the cache mapping parsers to compiled words." } ;
 
 HELP: token
 { $values 

extra/peg/peg.factor

@@ -14,9 +14,13 @@ SYMBOL: ignore
 : <parse-result> ( remaining ast -- parse-result )
   parse-result construct-boa ;
 
-SYMBOL: compiled-parsers
 SYMBOL: packrat
-SYMBOL: failed
+
+: compiled-parsers ( -- cache )
+  \ compiled-parsers get-global [ H{ } clone dup \ compiled-parsers set-global ] unless* ;
+
+: reset-compiled-parsers ( -- )
+  H{ } clone \ compiled-parsers set-global ;
 
 GENERIC: (compile) ( parser -- quot )
 
@@ -36,25 +40,24 @@ GENERIC: (compile) ( parser -- quot )
   #! Look to see if the given parser has been compiled.
   #! If not, compile it to a temporary word, cache it,
   #! and return it. Otherwise return the existing one.
-  dup compiled-parsers get at [
+  compiled-parsers [
-    nip
+    (compile) [ run-parser ] curry define-temp
-  ] [
+  ] cache ;
-    dup (compile) [ run-parser ] curry define-temp 
-    [ swap compiled-parsers get set-at ] keep
-  ] if* ;
 
 : compile ( parser -- word )
-  H{ } clone compiled-parsers [ 
+  [ compiled-parser ] with-compilation-unit ;
-    [ compiled-parser ] with-compilation-unit 
-  ] with-variable ;
 
 : parse ( state parser -- result )
   compile execute ;
 
+: with-packrat ( quot -- result )
+  #! Run the quotation with a packrat cache active.
+  [ H{ } clone packrat ] dip with-variable ;
+
 <PRIVATE
 
 TUPLE: token-parser symbol ;
-! M: token-parser equal? eq? ;
+M: token-parser equal? 2drop f ;
 
 MATCH-VARS: ?token ;
 
@@ -70,6 +73,7 @@ M: token-parser (compile) ( parser -- quot )
   symbol>> [ parse-token ] curry ;
       
 TUPLE: satisfy-parser quot ;
+M: satisfy-parser equal? 2drop f ;
 
 MATCH-VARS: ?quot ;
 
@@ -90,6 +94,7 @@ M: satisfy-parser (compile) ( parser -- quot )
   quot>> \ ?quot satisfy-pattern match-replace ;
 
 TUPLE: range-parser min max ;
+M: range-parser equal? 2drop f ;
 
 MATCH-VARS: ?min ?max ;
 
@@ -111,6 +116,7 @@ M: range-parser (compile) ( parser -- quot )
   T{ range-parser _ ?min ?max } range-pattern match-replace ;
 
 TUPLE: seq-parser parsers ;
+M: seq-parser equal? 2drop f ;
 
 : seq-pattern ( -- quot )
   [
@@ -137,6 +143,7 @@ M: seq-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: choice-parser parsers ;
+M: choice-parser equal? 2drop f ;
 
 : choice-pattern ( -- quot )
   [
@@ -155,6 +162,7 @@ M: choice-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: repeat0-parser p1 ;
+M: repeat0-parser equal? 2drop f ;
 
 : (repeat0) ( quot result -- result )
   2dup remaining>> swap call [
@@ -177,6 +185,7 @@ M: repeat0-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: repeat1-parser p1 ;
+M: repeat1-parser equal? 2drop f ;
 
 : repeat1-pattern ( -- quot )
   [
@@ -196,6 +205,7 @@ M: repeat1-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: optional-parser p1 ;
+M: optional-parser equal? 2drop f ;
 
 : optional-pattern ( -- quot )
   [
@@ -206,6 +216,7 @@ M: optional-parser (compile) ( parser -- quot )
   p1>> compiled-parser \ ?quot optional-pattern match-replace ;
 
 TUPLE: ensure-parser p1 ;
+M: ensure-parser equal? 2drop f ;
 
 : ensure-pattern ( -- quot )
   [
@@ -220,6 +231,7 @@ M: ensure-parser (compile) ( parser -- quot )
   p1>> compiled-parser \ ?quot ensure-pattern match-replace ;
 
 TUPLE: ensure-not-parser p1 ;
+M: ensure-not-parser equal? 2drop f ;
 
 : ensure-not-pattern ( -- quot )
   [
@@ -234,6 +246,7 @@ M: ensure-not-parser (compile) ( parser -- quot )
   p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ;
 
 TUPLE: action-parser p1 quot ;
+M: action-parser equal? 2drop f ;
 
 MATCH-VARS: ?action ;
 
@@ -257,6 +270,7 @@ M: action-parser (compile) ( parser -- quot )
   ] unless ;
 
 TUPLE: sp-parser p1 ;
+M: sp-parser equal? 2drop f ;
 
 M: sp-parser (compile) ( parser -- quot )
   [
@@ -264,6 +278,7 @@ M: sp-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: delay-parser quot ;
+M: delay-parser equal? 2drop f ;
 
 M: delay-parser (compile) ( parser -- quot )
   #! For efficiency we memoize the quotation.
@@ -277,70 +292,70 @@ M: delay-parser (compile) ( parser -- quot )
 
 PRIVATE>
 
-: token ( string -- parser )
+MEMO: token ( string -- parser )
   token-parser construct-boa ;      
 
-: satisfy ( quot -- parser )
+MEMO: satisfy ( quot -- parser )
   satisfy-parser construct-boa ;
 
-: range ( min max -- parser )
+MEMO: range ( min max -- parser )
   range-parser construct-boa ;
 
-: seq ( seq -- parser )
+MEMO: seq ( seq -- parser )
   seq-parser construct-boa ;
 
-: 2seq ( parser1 parser2 -- parser )
+MEMO: 2seq ( parser1 parser2 -- parser )
   2array seq ;
 
-: 3seq ( parser1 parser2 parser3 -- parser )
+MEMO: 3seq ( parser1 parser2 parser3 -- parser )
   3array seq ;
 
-: 4seq ( parser1 parser2 parser3 parser4 -- parser )
+MEMO: 4seq ( parser1 parser2 parser3 parser4 -- parser )
   4array seq ;
 
-: seq* ( quot -- paser )
+MEMO: seq* ( quot -- paser )
   { } make seq ; inline 
 
-: choice ( seq -- parser )
+MEMO: choice ( seq -- parser )
   choice-parser construct-boa ;
 
-: 2choice ( parser1 parser2 -- parser )
+MEMO: 2choice ( parser1 parser2 -- parser )
   2array choice ;
 
-: 3choice ( parser1 parser2 parser3 -- parser )
+MEMO: 3choice ( parser1 parser2 parser3 -- parser )
   3array choice ;
 
-: 4choice ( parser1 parser2 parser3 parser4 -- parser )
+MEMO: 4choice ( parser1 parser2 parser3 parser4 -- parser )
   4array choice ;
 
-: choice* ( quot -- paser )
+MEMO: choice* ( quot -- paser )
   { } make choice ; inline 
 
-: repeat0 ( parser -- parser )
+MEMO: repeat0 ( parser -- parser )
   repeat0-parser construct-boa ;
 
-: repeat1 ( parser -- parser )
+MEMO: repeat1 ( parser -- parser )
   repeat1-parser construct-boa ;
 
-: optional ( parser -- parser )
+MEMO: optional ( parser -- parser )
   optional-parser construct-boa ;
 
-: ensure ( parser -- parser )
+MEMO: ensure ( parser -- parser )
   ensure-parser construct-boa ;
 
-: ensure-not ( parser -- parser )
+MEMO: ensure-not ( parser -- parser )
   ensure-not-parser construct-boa ;
 
-: action ( parser quot -- parser )
+MEMO: action ( parser quot -- parser )
   action-parser construct-boa ;
 
-: sp ( parser -- parser )
+MEMO: sp ( parser -- parser )
   sp-parser construct-boa ;
 
 : hide ( parser -- parser )
   [ drop ignore ] action ;
 
-: delay ( quot -- parser )
+MEMO: delay ( quot -- parser )
   delay-parser construct-boa ;
 
 : PEG:

extra/serialize/serialize.factor

@@ -269,7 +269,7 @@ SYMBOL: deserialized
     [ ] tri ;
 
 : copy-seq-to-tuple ( seq tuple -- )
-    >r dup length [ 1+ ] map r> [ set-array-nth ] curry 2each ;
+    >r dup length r> [ set-array-nth ] curry 2each ;
 
 : deserialize-tuple ( -- array )
     #! Ugly because we have to intern the tuple before reading

extra/tuple-syntax/tuple-syntax.factor

@@ -1,5 +1,5 @@
 USING: kernel sequences slots parser words classes
-slots.private ;
+slots.private mirrors ;
 IN: tuple-syntax
 
 ! TUPLE: foo bar baz ;
@@ -10,8 +10,7 @@ IN: tuple-syntax
 
 : parse-slot-writer ( tuple -- slot# )
     scan dup "}" = [ 2drop f ] [
-        1 head* swap class "slots" word-prop
+        1 head* swap object-slots slot-named slot-spec-offset
-        [ slot-spec-name = ] with find nip slot-spec-offset
     ] if ;
 
 : parse-slots ( accum tuple -- accum tuple )

extra/tuples/lib/lib.factor

@@ -1,16 +1,16 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel macros sequences slots words ;
+USING: kernel macros sequences slots words mirrors ;
 IN: tuples.lib
 
 : reader-slots ( seq -- quot )
     [ slot-spec-reader ] map [ get-slots ] curry ;
 
 MACRO: >tuple< ( class -- )
-    "slots" word-prop 1 tail-slice reader-slots ;
+    all-slots 1 tail-slice reader-slots ;
 
 MACRO: >tuple*< ( class -- )
-    "slots" word-prop
+    all-slots
     [ slot-spec-name "*" tail? ] subset
     reader-slots ;
 

extra/xml/tests/errors.factor

@@ -16,7 +16,7 @@ T{ extra-attrs T{ parsing-error f 1 32 } V{ T{ name f "" "foo" f } }
 T{ bad-version T{ parsing-error f 1 28 } "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
 T{ notags f } "" xml-error-test
 T{ multitags f } "<x/><y/>" xml-error-test
-T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "iso-8859-1" f }
+T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "UTF-8" f }
 } "<x/><?xml version='1.0'?>" xml-error-test
 T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } "<?XmL version='1.0'?><x/>"
 xml-error-test

extra/xml/tests/templating.factor

@@ -40,4 +40,4 @@ M: object (r-ref) drop ;
         sample-doc string>xml dup template xml>string
     ] with-scope ;
 
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test
+[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test

extra/xml/tests/test.factor

@@ -26,7 +26,7 @@ SYMBOL: xml-file
 ] unit-test
 [ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
 [ "that" ] [ xml-file get "this" swap at ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><a b=\"c\"/>" ]
+[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
     [ "<a b='c'/>" string>xml xml>string ] unit-test
 [ "abcd" ] [
     "<main>a<sub>bc</sub>d<nothing/></main>" string>xml
@@ -44,7 +44,7 @@ SYMBOL: xml-file
     at swap "z" >r tuck r> swap set-at
     T{ name f "blah" "z" f } swap at ] unit-test
 [ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><foo>bar baz</foo>" ]
+[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
 [ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>\n  bar\n</foo>" ]
+[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo>\n  bar\n</foo>" ]
 [ "<foo>         bar            </foo>" string>xml pprint-xml>string ] unit-test

extra/xml/tokenize/tokenize.factor

@@ -172,7 +172,7 @@ SYMBOL: ns-stack
     [ T{ name f "" "version" f } swap at
       [ good-version ] [ <versionless-prolog> throw ] if* ] keep
     [ T{ name f "" "encoding" f } swap at
-      "iso-8859-1" or ] keep
+      "UTF-8" or ] keep
     T{ name f "" "standalone" f } swap at
     [ yes/no>bool ] [ f ] if*
     <prolog> ;

extra/xml/utilities/utilities.factor

@@ -42,7 +42,7 @@ M: process-missing error.
     >r 1array r> build-tag* ;
 
 : standard-prolog ( -- prolog )
-    T{ prolog f "1.0" "iso-8859-1" f } ;
+    T{ prolog f "1.0" "UTF-8" f } ;
 
 : build-xml ( tag -- xml )
     standard-prolog { } rot { } <xml> ;

extra/xml/xml.factor

@@ -63,7 +63,7 @@ M: closer process
     V{ } clone xml-stack set f push-xml ;
 
 : default-prolog ( -- prolog )
-    "1.0" "iso-8859-1" f <prolog> ;
+    "1.0" "UTF-8" f <prolog> ;
 
 : reset-prolog ( -- )
     default-prolog prolog-data set ;