From 2bc882bf5aabb65198a798fb645c65c90bceacf0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 25 Mar 2008 22:45:26 -0400 Subject: [PATCH 01/17] XML reports its encoding as UTF-8 --- extra/xml/tests/errors.factor | 2 +- extra/xml/tests/templating.factor | 2 +- extra/xml/tests/test.factor | 6 +++--- extra/xml/tokenize/tokenize.factor | 2 +- extra/xml/utilities/utilities.factor | 2 +- extra/xml/xml.factor | 2 +- 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/xml/tests/errors.factor b/extra/xml/tests/errors.factor index b421ae011a..6ba0b0d560 100755 --- a/extra/xml/tests/errors.factor +++ b/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-error-test T{ notags f } "" xml-error-test T{ multitags f } "" 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 } } "" xml-error-test T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } "" xml-error-test diff --git a/extra/xml/tests/templating.factor b/extra/xml/tests/templating.factor index 6db98ec848..d81e807fe5 100644 --- a/extra/xml/tests/templating.factor +++ b/extra/xml/tests/templating.factor @@ -40,4 +40,4 @@ M: object (r-ref) drop ; sample-doc string>xml dup template xml>string ] with-scope ; -[ "foo
blah

" ] [ test-refs ] unit-test +[ "foo

" ] [ test-refs ] unit-test diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor index 02c7aecb13..98146136e6 100644 --- a/extra/xml/tests/test.factor +++ b/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 -[ "" ] +[ "" ] [ "" string>xml xml>string ] unit-test [ "abcd" ] [ "

abcd
" 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" ] [ "" string>xml children>string ] unit-test -[ "bar baz" ] +[ "bar baz" ] [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test -[ "\n\n bar\n" ] +[ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor index d99c306b2b..b2b7d78b3e 100644 --- a/extra/xml/tokenize/tokenize.factor +++ b/extra/xml/tokenize/tokenize.factor @@ -172,7 +172,7 @@ SYMBOL: ns-stack [ T{ name f "" "version" f } swap at [ good-version ] [ 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* ; diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index d6814851ee..b397e3c7b1 100755 --- a/extra/xml/utilities/utilities.factor +++ b/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 { } ; diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor index 970ff39cf1..61ef27b72e 100644 --- a/extra/xml/xml.factor +++ b/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 ; + "1.0" "UTF-8" f ; : reset-prolog ( -- ) default-prolog prolog-data set ; From 64203f762d23849b23f0421f20b6123bcd0e6665 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 26 Mar 2008 14:41:09 -0400 Subject: [PATCH 02/17] Docs improvements; simplification of design of io.encodings.8-bit --- core/io/encodings/encodings-docs.factor | 15 +++++--- extra/help/handbook/handbook.factor | 11 ++++-- extra/io/encodings/8-bit/8-bit-docs.factor | 8 +++-- extra/io/encodings/8-bit/8-bit.factor | 41 ++++++++-------------- extra/io/encodings/utf16/utf16-docs.factor | 12 ++++--- 5 files changed, 47 insertions(+), 40 deletions(-) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 07e0f9f401..bdd9e56d87 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -19,20 +19,23 @@ HELP: { $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: { $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: { $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 ; { } 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 diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 4079386d7f..8963c2b1ad 100755 --- a/extra/help/handbook/handbook.factor +++ b/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 " } +{ $code "\"file.txt\" utf8 " } "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 " } ; +{ $code "\"file.txt\" utf8 strict " } +"In a similar way, encodings can be specified when opening a file for writing." +{ $code "\"file.txt\" ascii " } +"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" } diff --git a/extra/io/encodings/8-bit/8-bit-docs.factor b/extra/io/encodings/8-bit/8-bit-docs.factor index 8e5fd815bc..e8dadc13f7 100644 --- a/extra/io/encodings/8-bit/8-bit-docs.factor +++ b/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." } diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index c041e699a2..2e33075df0 100644 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/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 ; +classes quotations math compiler.units accessors ; IN: io.encodings.8-bit ch ] [ ch>byte ] bi ; -: empty-tuple-class ( string -- class ) - in get create - dup { f } "slots" set-word-prop - dup predicate-word drop - dup { } define-tuple-class ; +TUPLE: 8-bit name decode encode ; -: data-quot ( class word data -- quot ) - >r [ word-name ] 2apply "/" swap 3append - "/data" append in get create dup 1quotation swap r> - 1quotation define ; +: encode-8-bit ( char stream assoc -- ) + swapd at* [ encode-error ] unless swap stream-write1 ; -: method-with-data ( class data word quot -- ) - >r swap >r 2dup r> data-quot r> - compose >r create-method r> define ; +M: 8-bit encode-char + encode>> encode-8-bit ; -: encode-8-bit ( char stream encoding assoc -- ) - nip swapd at* [ encode-error ] unless swap stream-write1 ; - -: 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 +: decode-8-bit ( stream array -- char/f ) + swap stream-read1 dup [ swap nth [ replacement-char ] unless* ] - [ drop f ] if* ; + [ nip ] if ; -: define-decode-char ( class array -- ) - \ decode-char [ decode-8-bit ] method-with-data ; +M: 8-bit decode-char + decode>> decode-8-bit ; -: 8-bit-methods ( class byte>ch ch>byte -- ) - >r over r> define-encode-char define-decode-char ; +: make-8-bit ( word byte>ch ch>byte -- ) + [ 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> diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor index 7198cb2b27..bc0e943415 100644 --- a/extra/io/encodings/utf16/utf16-docs.factor +++ b/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 From e6da3bc43a66f23b75586c4b320208fed4c59579 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 14:55:14 +1300 Subject: [PATCH 03/17] Use cache in compiled-parser in peg --- extra/peg/peg.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index dd0b11fce3..fe58962f48 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -16,7 +16,6 @@ SYMBOL: ignore SYMBOL: compiled-parsers SYMBOL: packrat -SYMBOL: failed GENERIC: (compile) ( parser -- quot ) @@ -36,12 +35,9 @@ 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 [ - nip - ] [ - dup (compile) [ run-parser ] curry define-temp - [ swap compiled-parsers get set-at ] keep - ] if* ; + compiled-parsers get [ + (compile) [ run-parser ] curry define-temp + ] cache ; : compile ( parser -- word ) H{ } clone compiled-parsers [ From 7c0535884eeb8d770ad0d09a18221d1438c7b2e4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 15:21:38 +1300 Subject: [PATCH 04/17] Fix up peg memoization of compiled parsers --- extra/peg/peg.factor | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index fe58962f48..c994c5aa29 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -14,9 +14,14 @@ SYMBOL: ignore : ( remaining ast -- parse-result ) parse-result construct-boa ; -SYMBOL: compiled-parsers SYMBOL: packrat +: 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 ) :: run-packrat-parser ( input quot c -- result ) @@ -35,14 +40,12 @@ 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. - compiled-parsers get [ + compiled-parsers [ (compile) [ run-parser ] curry define-temp ] cache ; : compile ( parser -- word ) - H{ } clone compiled-parsers [ - [ compiled-parser ] with-compilation-unit - ] with-variable ; + [ compiled-parser ] with-compilation-unit ; : parse ( state parser -- result ) compile execute ; From 708726d20838833899ce7ddfb9aae19efa10bc1a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 27 Mar 2008 15:50:27 +1300 Subject: [PATCH 05/17] Add with-packrat word and more memoization --- extra/peg/parsers/parsers.factor | 17 ++++----- extra/peg/peg-docs.factor | 31 ++++++++++++++++- extra/peg/peg.factor | 60 ++++++++++++++++++++------------ 3 files changed, 77 insertions(+), 31 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 13509e81f7..fa6801dc1c 100755 --- a/extra/peg/parsers/parsers.factor +++ b/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 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 diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 9ad375ea04..30e7f0e72f 100644 --- a/extra/peg/peg-docs.factor +++ b/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 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 diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index c994c5aa29..10c9ce907d 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -50,10 +50,14 @@ GENERIC: (compile) ( parser -- quot ) : parse ( state parser -- result ) compile execute ; +: with-packrat ( quot -- result ) + #! Run the quotation with a packrat cache active. + [ H{ } clone packrat ] dip with-variable ; + > [ parse-token ] curry ; TUPLE: satisfy-parser quot ; +M: satisfy-parser equal? 2drop f ; MATCH-VARS: ?quot ; @@ -89,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 ; @@ -110,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 ) [ @@ -136,6 +143,7 @@ M: seq-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: choice-parser parsers ; +M: choice-parser equal? 2drop f ; : choice-pattern ( -- quot ) [ @@ -154,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 [ @@ -176,6 +185,7 @@ M: repeat0-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: repeat1-parser p1 ; +M: repeat1-parser equal? 2drop f ; : repeat1-pattern ( -- quot ) [ @@ -195,6 +205,7 @@ M: repeat1-parser (compile) ( parser -- quot ) ] [ ] make ; TUPLE: optional-parser p1 ; +M: optional-parser equal? 2drop f ; : optional-pattern ( -- quot ) [ @@ -205,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 ) [ @@ -219,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 ) [ @@ -233,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 ; @@ -256,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 ) [ @@ -263,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. @@ -276,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: From f05fef0a630c73b13e60caedae3dec6931d092e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 26 Mar 2008 23:11:55 -0500 Subject: [PATCH 06/17] Fix PowerPC compiler backend --- core/cpu/ppc/intrinsics/intrinsics.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 570cd42576..8a2f41ec12 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/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 From caf3ebb31d9278970cf78bdcc80e98f0f320c121 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 27 Mar 2008 00:32:41 -0400 Subject: [PATCH 07/17] Fixing 8-bit encodings --- extra/io/encodings/8-bit/8-bit.factor | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 2e33075df0..d29760a3e0 100644 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/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 accessors ; +math compiler.units accessors ; IN: io.encodings.8-bit ] map ] map ; + [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ; : byte>ch ( assoc -- array ) 256 replacement-char @@ -77,4 +77,8 @@ M: 8-bit decode-char 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 From 15c68a23f85a16480cdfe4b8bc74849510153a47 Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 26 Mar 2008 23:47:51 -0500 Subject: [PATCH 08/17] remove ?resource-path and resource-exists? --- core/bootstrap/stage1.factor | 2 +- core/io/files/files-docs.factor | 9 --------- core/io/files/files-tests.factor | 4 ++++ core/io/files/files.factor | 20 +++++++++++-------- core/parser/parser.factor | 4 ++-- core/source-files/source-files.factor | 2 +- core/vocabs/loader/loader.factor | 2 +- extra/editors/editors.factor | 4 ++-- .../templating/fhtml/fhtml-tests.factor | 2 +- .../http/server/templating/fhtml/fhtml.factor | 2 +- extra/project-euler/project-euler.factor | 2 +- extra/tools/deploy/test/3/3.factor | 2 +- extra/tools/vocabs/vocabs.factor | 17 ++++++++-------- extra/ui/freetype/freetype.factor | 2 +- 14 files changed, 36 insertions(+), 38 deletions(-) diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 74b4d03cbb..34f758c9df 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -39,7 +39,7 @@ vocabs.loader system debugger continuations ; [ "resource:core/bootstrap/stage2.factor" - dup resource-exists? [ + dup exists? [ [ run-file ] [ :c diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 1a3bde0e5c..1953569223 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -20,9 +20,6 @@ ARTICLE: "pathnames" "Pathname manipulation" { $subsection file-name } { $subsection last-path-separator } { $subsection append-path } -"Pathnames relative to Factor's install directory:" -{ $subsection resource-path } -{ $subsection ?resource-path } "Pathnames relative to Factor's temporary files directory:" { $subsection temp-directory } { $subsection temp-file } @@ -248,12 +245,6 @@ HELP: resource-path { $values { "path" "a pathname string" } { "newpath" "a pathname string" } } { $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ; -HELP: ?resource-path -{ $values { "path" "a pathname string" } { "newpath" "a string" } } -{ $description "If the path is prefixed with " { $snippet "\"resource:\"" } ", prepends the resource path." } ; - -{ resource-path ?resource-path } related-words - HELP: pathname { $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 369ecc6868..9af82a5672 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -205,3 +205,7 @@ io.encodings.utf8 ; [ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test [ "bar/foo" ] [ "bar/baz" "./..//foo" append-path ] unit-test [ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test + +[ t ] [ "resource:core" absolute-path? ] unit-test +[ t ] [ "/foo" absolute-path? ] unit-test +[ f ] [ "" absolute-path? ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 78f1612cb8..0090f90e4c 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -99,7 +99,12 @@ ERROR: no-parent-directory path ; PRIVATE> : absolute-path? ( path -- ? ) - dup empty? [ drop f ] [ first path-separator? ] if ; + { + { [ dup empty? ] [ f ] } + { [ dup "resource:" head? ] [ t ] } + { [ dup first path-separator? ] [ t ] } + { [ t ] [ f ] } + } cond nip ; : append-path ( str1 str2 -- str ) { @@ -258,12 +263,6 @@ DEFER: copy-tree-into "resource-path" get [ image parent-directory ] unless* prepend-path ; -: ?resource-path ( path -- newpath ) - "resource:" ?head [ left-trim-separators resource-path ] when ; - -: resource-exists? ( path -- ? ) - ?resource-path exists? ; - : temp-directory ( -- path ) "temp" resource-path dup exists? not @@ -273,7 +272,12 @@ DEFER: copy-tree-into : temp-file ( name -- path ) temp-directory prepend-path ; M: object normalize-pathname ( path -- path' ) - current-directory get prepend-path ; + "resource:" ?head [ + left-trim-separators resource-path + normalize-pathname + ] [ + current-directory get prepend-path + ] if ; ! Pathname presentations TUPLE: pathname string ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index bb3ad254da..f6e351a42e 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -520,7 +520,7 @@ SYMBOL: interactive-vocabs [ [ [ parsing-file ] keep - [ ?resource-path utf8 ] keep + [ utf8 ] keep parse-stream ] with-compiler-errors ] [ @@ -532,7 +532,7 @@ SYMBOL: interactive-vocabs [ dup parse-file call ] assert-depth drop ; : ?run-file ( path -- ) - dup resource-exists? [ run-file ] [ drop ] if ; + dup exists? [ run-file ] [ drop ] if ; : bootstrap-file ( path -- ) [ parse-file % ] [ run-file ] if-bootstrapping ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index f4428e4e8b..8dea367b6b 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -48,7 +48,7 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ - swap ?resource-path dup exists? [ + swap dup exists? [ utf8 file-lines swap record-checksum ] [ 2drop ] if ] assoc-each ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 9478c1f4f7..57947eefb0 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -25,7 +25,7 @@ V{ : vocab-dir? ( root name -- ? ) over [ - ".factor" vocab-dir+ append-path resource-exists? + ".factor" vocab-dir+ append-path exists? ] [ 2drop f ] if ; diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 4ee906bccb..89aef4d819 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -26,7 +26,7 @@ SYMBOL: edit-hook : edit-location ( file line -- ) edit-hook get [ - >r >r ?resource-path r> r> call + call ] [ no-edit-hook edit-location ] if* ; @@ -39,7 +39,7 @@ SYMBOL: edit-hook : :edit ( -- ) error get delegates [ parse-error? ] find-last nip [ - dup parse-error-file source-file-path ?resource-path + dup parse-error-file source-file-path swap parse-error-line edit-location ] when* ; diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index 2e253d9132..9d8a6f4617 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -9,7 +9,7 @@ IN: http.server.templating.fhtml.tests [ ".fhtml" append [ run-template ] with-string-writer ] keep - ".html" append ?resource-path utf8 file-contents = ; + ".html" append utf8 file-contents = ; [ t ] [ "example" test-template ] unit-test [ t ] [ "bug" test-template ] unit-test diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 630054ccfa..f3d9d54a25 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -83,7 +83,7 @@ DEFER: <% delimiter templating-vocab use+ ! so that reload works properly dup source-file file set - ?resource-path utf8 file-contents + utf8 file-contents [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs ] assert-depth ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 04339ad5b7..9325e74d93 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -31,7 +31,7 @@ IN: project-euler : solution-path ( n -- str/f ) number>euler "project-euler." prepend - vocab where dup [ first ?resource-path ] when ; + vocab where dup [ first ] when ; PRIVATE> diff --git a/extra/tools/deploy/test/3/3.factor b/extra/tools/deploy/test/3/3.factor index 443e82f7d9..2f07f4ede5 100755 --- a/extra/tools/deploy/test/3/3.factor +++ b/extra/tools/deploy/test/3/3.factor @@ -3,6 +3,6 @@ USING: io.encodings.ascii io.files kernel ; : deploy-test-3 "resource:extra/tools/deploy/test/3/3.factor" - ?resource-path ascii file-contents drop ; + ascii file-contents drop ; MAIN: deploy-test-3 diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index b086b30a5e..d7c3d2be20 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -8,12 +8,12 @@ IN: tools.vocabs : vocab-tests-file ( vocab -- path ) dup "-tests.factor" vocab-dir+ vocab-append-path dup - [ dup resource-exists? [ drop f ] unless ] [ drop f ] if ; + [ dup exists? [ drop f ] unless ] [ drop f ] if ; : vocab-tests-dir ( vocab -- paths ) dup vocab-dir "tests" append-path vocab-append-path dup [ - dup resource-exists? [ - dup ?resource-path directory keys + dup exists? [ + dup directory keys [ ".factor" tail? ] subset [ append-path ] with map ] [ drop f ] if @@ -34,7 +34,7 @@ IN: tools.vocabs : source-modified? ( path -- ? ) dup source-files get at [ - dup source-file-path ?resource-path + dup source-file-path dup exists? [ utf8 file-lines lines-crc32 swap source-file-checksum = not @@ -42,7 +42,7 @@ IN: tools.vocabs 2drop f ] if ] [ - resource-exists? + exists? ] ?if ; : modified ( seq quot -- seq ) @@ -104,15 +104,14 @@ SYMBOL: sources-changed? "" refresh f sources-changed? set-global ; MEMO: (vocab-file-contents) ( path -- lines ) - ?resource-path dup exists? - [ utf8 file-lines ] [ drop f ] if ; + dup exists? [ utf8 file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) vocab-append-path dup [ (vocab-file-contents) ] when ; : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-append-path [ - ?resource-path utf8 set-file-lines + utf8 set-file-lines \ (vocab-file-contents) reset-memoized ] [ "The " swap vocab-name @@ -171,7 +170,7 @@ M: vocab-link summary vocab-summary ; directory [ second ] subset keys natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) - [ vocab-dir append-path ?resource-path subdirs ] keep + [ vocab-dir append-path subdirs ] keep dup empty? [ drop ] [ diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index dc56009b87..1963f5670a 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -62,7 +62,7 @@ M: freetype-renderer free-fonts ( world -- ) } at ; : ttf-path ( name -- string ) - "resource:fonts/" swap ".ttf" 3append ?resource-path ; + "resource:fonts/" swap ".ttf" 3append ; : (open-face) ( path length -- face ) #! We use FT_New_Memory_Face, not FT_New_Face, since From 8903ba3a32257e4c99ac3c41496ea7f0527a13ff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 01:41:22 -0500 Subject: [PATCH 09/17] Fix Windows bootstrap --- extra/io/windows/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index b4513f7da8..655b5f9daf 100755 --- a/extra/io/windows/files/files.factor +++ b/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 ; From 5aae4516dde997ff042211b9a584de02bb9db9e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 01:42:13 -0500 Subject: [PATCH 10/17] Working on slot inheritance --- core/bootstrap/primitives.factor | 18 +++++--- core/classes/classes.factor | 3 ++ core/mirrors/mirrors.factor | 2 +- core/tuples/tuples-tests.factor | 26 ++++++++++-- core/tuples/tuples.factor | 71 ++++++++++++++++++++++---------- 5 files changed, 89 insertions(+), 31 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 3f6fedb40c..baa85032bc 100755 --- a/core/bootstrap/primitives.factor +++ b/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" } - "layout" - { "tuple-layout" "tuples.private" } - f + { "object" "kernel" } + "delegate" + { "delegate" "kernel" } + { "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 diff --git a/core/classes/classes.factor b/core/classes/classes.factor index c2c19836cd..c21dd452ac 100755 --- a/core/classes/classes.factor +++ b/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 ; diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 8f12bbb2f4..7176076c7c 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -10,7 +10,7 @@ GENERIC: object-slots ( obj -- seq ) M: object object-slots class "slots" word-prop ; M: tuple object-slots - dup class "slots" word-prop + dup class superclasses [ "slots" word-prop ] map concat swap delegate [ 1 tail-slice ] unless ; TUPLE: mirror object slots ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 2d28697b70..e670c26c25 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -246,6 +246,7 @@ C: erg's-reshape-problem ! Inheritance TUPLE: computer cpu ram ; +C: computer [ "TUPLE: computer cpu ram ;" ] [ [ \ computer see ] with-string-writer string-lines second @@ -264,11 +265,23 @@ C: 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 [ t ] [ server tuple-class? ] unit-test @@ -276,11 +289,15 @@ C: server [ t ] [ server computer class< ] unit-test [ t ] [ server computer classes-intersect? ] unit-test -[ ] [ "Pentium" 128 "1U" "server" set ] unit-test +[ ] [ "PowerPC" 64 "1U" "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 [ f ] [ laptop server class< ] unit-test [ f ] [ laptop server classes-intersect? ] unit-test -[ "TUPLE: server < computer rackmount? ;" ] [ +[ f ] [ 1 2 laptop? ] unit-test +[ f ] [ \ + server? ] unit-test + +[ "TUPLE: server < computer rackmount ;" ] [ [ \ server see ] with-string-writer string-lines second ] unit-test diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 83f398242a..09dd03de2f 100755 --- a/core/tuples/tuples.factor +++ b/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 ; @@ -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 - [ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry - define-predicate ; + dup tuple-predicate-quot define-predicate ; -: delegate-slot-spec - T{ slot-spec f - object - "delegate" - 2 - delegate - set-delegate - } ; +: superclass-size ( class -- n ) + superclasses 1 head-slice* + [ "slot-names" word-prop length ] map sum ; + +: generate-tuple-slots ( class slots -- slot-specs slot-names ) + over superclass-size 2 + simple-slots + dup [ slot-spec-name ] map ; : define-tuple-slots ( class slots -- ) - dupd 3 simple-slots - 2dup [ slot-spec-name ] map "slot-names" set-word-prop - 2dup delegate-slot-spec add* "slots" set-word-prop - 2dup define-slots - define-accessors ; + dupd generate-tuple-slots + >r dupd "slots" set-word-prop + r> dupd "slot-names" set-word-prop + dup "slots" word-prop 2dup define-slots define-accessors ; + +: make-tuple-layout ( class -- layout ) + dup superclass-size over "slot-names" word-prop length + + over superclasses dup length 1- ; : define-tuple-layout ( class -- ) - dup - dup "slot-names" word-prop length 1+ { } 0 - "layout" set-word-prop ; + dup make-tuple-layout "layout" set-word-prop ; : removed-slots ( class newslots -- seq ) swap "slot-names" word-prop seq-diff ; From f1ee3dcb32e61b47f92fe5de911f4a24ea4bc7d8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 02:12:15 -0500 Subject: [PATCH 11/17] Clean up temp-directory --- core/io/files/files.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 78f1612cb8..7cdf41674d 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -265,12 +265,10 @@ DEFER: copy-tree-into ?resource-path exists? ; : temp-directory ( -- path ) - "temp" resource-path - dup exists? not - [ dup make-directory ] - when ; + "temp" resource-path dup make-directories ; -: temp-file ( name -- path ) temp-directory prepend-path ; +: temp-file ( name -- path ) + temp-directory prepend-path ; M: object normalize-pathname ( path -- path' ) current-directory get prepend-path ; From b008f69c25c4c39b394559b107830ed44e6c6bc1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 03:27:22 -0500 Subject: [PATCH 12/17] Fix serialize --- extra/serialize/serialize.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 7bcc336962..a86eee71e3 100755 --- a/extra/serialize/serialize.factor +++ b/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 From febcd88459f0e8a04189eb365c5a530b94a05493 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 05:13:52 -0500 Subject: [PATCH 13/17] Unit test fixes --- core/assocs/assocs-tests.factor | 4 ++-- core/classes/algebra/algebra-docs.factor | 2 +- core/compiler/tests/templates.factor | 4 ++-- core/mirrors/mirrors-tests.factor | 2 +- core/mirrors/mirrors.factor | 10 ++++------ core/tuples/tuples-docs.factor | 2 +- core/tuples/tuples.factor | 2 +- extra/inverse/inverse.factor | 4 ++-- extra/tuple-syntax/tuple-syntax.factor | 5 ++--- extra/tuples/lib/lib.factor | 6 +++--- 10 files changed, 19 insertions(+), 22 deletions(-) mode change 100644 => 100755 extra/tuples/lib/lib.factor diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 574002921a..c4db604784 100755 --- a/core/assocs/assocs-tests.factor +++ b/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 diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 632af1d040..87c72048f4 100755 --- a/core/classes/algebra/algebra-docs.factor +++ b/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" } "." } ; diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 1c19730ec0..8a33d57fe7 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -81,8 +81,8 @@ unit-test -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call ] unit-test -[ 2 ] [ - SBUF" " [ 2 slot 2 [ slot ] keep ] compile-call nip +[ 1 ] [ + SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip ] unit-test ! Test slow shuffles diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor index 8f2964b19d..11e5772000 100755 --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -5,7 +5,7 @@ TUPLE: foo bar baz ; C: foo -[ { "bar" "baz" } ] [ 1 2 keys ] unit-test +[ { "delegate" "bar" "baz" } ] [ 1 2 keys ] unit-test [ 1 t ] [ "bar" 1 2 at* ] unit-test diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 7176076c7c..3c5a0aa3c7 100755 --- a/core/mirrors/mirrors.factor +++ b/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 ; - -M: tuple object-slots - dup class superclasses [ "slots" word-prop ] map concat - swap delegate [ 1 tail-slice ] unless ; +: object-slots ( obj -- seq ) + class all-slots ; TUPLE: mirror object slots ; diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 6e0f319c9a..55e15d6dc6 100755 --- a/core/tuples/tuples-docs.factor +++ b/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." } diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 09dd03de2f..89aff6f185 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -36,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 [ >r 1 tail-slice dup length r> [ tuple-size min ] keep diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 1468065ebe..308bf36bf4 100755 --- a/extra/inverse/inverse.factor +++ b/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 ; diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor index 2f0ba6bde5..f06bb55899 100755 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/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 - [ slot-spec-name = ] with find nip slot-spec-offset + 1 head* swap object-slots slot-named slot-spec-offset ] if ; : parse-slots ( accum tuple -- accum tuple ) diff --git a/extra/tuples/lib/lib.factor b/extra/tuples/lib/lib.factor old mode 100644 new mode 100755 index 5075c1d94a..4c007c8bb1 --- a/extra/tuples/lib/lib.factor +++ b/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 ; From 65bfc092652a60152af35e87cad5cb0ccec911dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 05:18:07 -0500 Subject: [PATCH 14/17] Fix HTTP server --- extra/http/server/static/static.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 37c3a63d76..2f48e7ac87 100755 --- a/extra/http/server/static/static.factor +++ b/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 From e39894155c1d983e2a6dd5aa358b747305a06806 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 27 Mar 2008 09:00:59 -0500 Subject: [PATCH 15/17] add windows-absolute-path? and move unit tests --- core/io/files/files.factor | 10 +++++++++- extra/io/windows/nt/files/files-tests.factor | 11 +++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) create mode 100644 extra/io/windows/nt/files/files-tests.factor diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3913f3c8d5..94401f3e1f 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,7 +3,7 @@ USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs continuations io.encodings -io.encodings.binary init ; +io.encodings.binary init unicode.categories ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -98,11 +98,19 @@ ERROR: no-parent-directory path ; PRIVATE> +: windows-absolute-path? ( path -- path ? ) + { + { [ dup length 2 < ] [ f ] } + { [ dup first2 >r Letter? r> CHAR: : = and ] [ t ] } + { [ t ] [ f ] } + } cond ; + : absolute-path? ( path -- ? ) { { [ dup empty? ] [ f ] } { [ dup "resource:" head? ] [ t ] } { [ dup first path-separator? ] [ t ] } + { [ windows? ] [ windows-absolute-path? ] } { [ t ] [ f ] } } cond nip ; diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor new file mode 100644 index 0000000000..a96bd6dad8 --- /dev/null +++ b/extra/io/windows/nt/files/files-tests.factor @@ -0,0 +1,11 @@ +USING: kernel tools.test ; +IN: io.windows.nt.files.tests + +[ f ] [ "" root-directory? ] unit-test +[ t ] [ "\\" root-directory? ] unit-test +[ t ] [ "\\\\" root-directory? ] unit-test +[ t ] [ "\\\\\\\\\\\\" root-directory? ] unit-test +[ t ] [ "/" root-directory? ] unit-test +[ t ] [ "//" root-directory? ] unit-test +[ t ] [ "//////////////" root-directory? ] unit-test +[ t ] [ "\\foo" absolute-path? ] unit-test From f54d12682a6608d5fe7ab7b279ef16e21875f896 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 27 Mar 2008 09:01:48 -0500 Subject: [PATCH 16/17] add more unit tests for windows --- extra/io/windows/nt/files/files-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor index a96bd6dad8..3b31d73e4a 100644 --- a/extra/io/windows/nt/files/files-tests.factor +++ b/extra/io/windows/nt/files/files-tests.factor @@ -9,3 +9,7 @@ IN: io.windows.nt.files.tests [ t ] [ "//" root-directory? ] unit-test [ t ] [ "//////////////" root-directory? ] unit-test [ t ] [ "\\foo" absolute-path? ] unit-test +[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test +[ t ] [ "c:\\foo" absolute-path? ] unit-test +[ t ] [ "c:" absolute-path? ] unit-test + From 15139b06ec4c15db960ae6047a0fbbf1152c4343 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 27 Mar 2008 09:06:06 -0500 Subject: [PATCH 17/17] can't use unicode or ascii in io.files.. --- core/io/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 94401f3e1f..f6888bf78d 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,7 +3,7 @@ USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs continuations io.encodings -io.encodings.binary init unicode.categories ; +io.encodings.binary init ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -101,7 +101,7 @@ PRIVATE> : windows-absolute-path? ( path -- path ? ) { { [ dup length 2 < ] [ f ] } - { [ dup first2 >r Letter? r> CHAR: : = and ] [ t ] } + { [ dup second CHAR: : = ] [ t ] } { [ t ] [ f ] } } cond ;