From f50821af6e14025dcd049601645dfaf17a62e014 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Wed, 12 Mar 2008 02:11:03 -0700 Subject: [PATCH 01/36] Implement sequence matching in extra/match. --- extra/match/match.factor | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/extra/match/match.factor b/extra/match/match.factor index 722c330a32..36af5c990a 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -65,3 +65,26 @@ MACRO: match-cond ( assoc -- ) -rot match [ "Pattern does not match" throw ] unless* [ replace-patterns ] bind ; + +: ?1-tail ( seq -- tail/f ) + dup length zero? not [ 1 tail ] [ drop f ] if ; + +: (match-first) ( seq pattern-seq -- bindings leftover/f ) + 2dup [ length ] 2apply < [ 2drop f f ] + [ + 2dup length head over match + [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if* + ] if ; + +: match-first ( seq pattern-seq -- bindings ) + (match-first) drop ; + +: (match-all) ( seq pattern-seq -- ) + tuck (match-first) swap + [ + , [ swap (match-all) ] [ drop ] if* + ] [ 2drop ] if* ; + +: match-all ( seq pattern-seq -- bindings-seq ) + [ (match-all) ] { } make ; + From 78633e03a0d9951407e33c01c8e33eac0205657e Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sun, 30 Mar 2008 19:01:47 +1300 Subject: [PATCH 02/36] Allow var names in ebnf but ignore them for now --- extra/peg/ebnf/ebnf.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index af61c3aae0..0ae1430c8c 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -19,6 +19,7 @@ TUPLE: ebnf-repeat1 group ; TUPLE: ebnf-optional group ; TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-action parser code ; +TUPLE: ebnf-var parser name ; TUPLE: ebnf rules ; C: ebnf-non-terminal @@ -34,6 +35,7 @@ C: ebnf-repeat1 C: ebnf-optional C: ebnf-rule C: ebnf-action +C: ebnf-var C: ebnf : syntax ( string -- parser ) @@ -79,6 +81,7 @@ C: ebnf [ dup CHAR: * = ] [ dup CHAR: + = ] [ dup CHAR: ? = ] + [ dup CHAR: : = ] } || not nip ] satisfy repeat1 [ >string ] action ; @@ -200,6 +203,7 @@ DEFER: 'choice' : 'actioned-sequence' ( -- parser ) [ [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 ] action , + [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , 'sequence' , ] choice* ; @@ -270,6 +274,9 @@ M: ebnf-action (transform) ( ast -- parser ) [ parser>> (transform) ] keep code>> string-lines [ parse-lines ] with-compilation-unit action ; +M: ebnf-var (transform) ( ast -- parser ) + parser>> (transform) ; + M: ebnf-terminal (transform) ( ast -- parser ) symbol>> token sp ; From bb8198d3d0163e0cacc701e21588c16e858d2b08 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sun, 30 Mar 2008 23:24:02 +1300 Subject: [PATCH 03/36] Declare stack effects for compiled parsers --- extra/peg/ebnf/ebnf.factor | 4 ++-- extra/peg/peg.factor | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 0ae1430c8c..41b5a1b655 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -3,7 +3,7 @@ USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg peg.parsers unicode.categories multiline combinators.lib - splitting accessors ; + splitting accessors effects ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -310,5 +310,5 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : EBNF: CREATE-WORD dup ";EBNF" parse-multiline-string - ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing + ebnf>quot swapd 1 1 define-declared "ebnf-parser" set-word-prop ; parsing diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8621b43a7f..a09962783b 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words quotations effects memoize accessors locals ; + words quotations effects memoize accessors locals effects ; IN: peg USE: prettyprint @@ -206,7 +206,7 @@ GENERIC: (compile) ( parser -- quot ) :: parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - [let* | rule [ parser (compile) define-temp dup parser "peg" set-word-prop ] + [let* | rule [ gensym dup parser (compile) 0 1 define-declared dup parser "peg" set-word-prop ] | [ rule pos get apply-rule dup fail = [ @@ -216,7 +216,7 @@ GENERIC: (compile) ( parser -- quot ) ] if ] ] ; - + : compiled-parser ( parser -- word ) #! Look to see if the given parser has been compiled. #! If not, compile it to a temporary word, cache it, @@ -227,7 +227,7 @@ GENERIC: (compile) ( parser -- quot ) dup compiled>> [ nip ] [ - gensym tuck >>compiled 2dup parser-body define dupd "peg" set-word-prop + gensym tuck >>compiled 2dup parser-body 0 1 define-declared dupd "peg" set-word-prop ] if* ; : compile ( parser -- word ) From 5989680a7b992b392dbb57ca99f3909140f2b879 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 00:53:33 +1300 Subject: [PATCH 04/36] Ensure box parsers are never cached --- extra/peg/peg.factor | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index a09962783b..e07942a3cd 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -488,8 +488,11 @@ M: box-parser (compile) ( parser -- quot ) #! Calls the quotation at compile time #! to produce the parser to be compiled. #! This differs from 'delay' which calls - #! it at run time. - quot>> call compiled-parser 1quotation ; + #! it at run time. Due to using the runtime + #! environment at compile time, this parser + #! must not be cached, so we clear out the + #! delgates cache. + f >>compiled quot>> call compiled-parser 1quotation ; PRIVATE> @@ -560,7 +563,12 @@ PRIVATE> delay-parser construct-boa init-parser ; : box ( quot -- parser ) - box-parser construct-boa init-parser ; + #! because a box has its quotation run at compile time + #! it must always have a new parser delgate created, + #! not a cached one. This is because the same box, + #! compiled twice can have a different compiled word + #! due to running at compile time. + box-parser construct-boa next-id f over set-delegate ; : PEG: (:) [ From 8bc2589a7a75bdee2e8c5c057b240a74f5eab062 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 08:16:07 -0500 Subject: [PATCH 05/36] Documentation updates --- core/kernel/kernel-docs.factor | 69 ++++++++++++++++++++++++----- extra/help/cookbook/cookbook.factor | 33 ++++++++++---- 2 files changed, 84 insertions(+), 18 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index a446869096..1c88f5a485 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -7,6 +7,8 @@ IN: kernel ARTICLE: "shuffle-words" "Shuffle words" "Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions." $nl +"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "." +$nl "Removing stack elements:" { $subsection drop } { $subsection 2drop } @@ -39,9 +41,28 @@ $nl { $code ": foo ( m ? n -- m+n/n )" " >r [ r> + ] [ drop r> ] if ; ! This is OK" -} -"An alternative to using " { $link >r } " and " { $link r> } " is the following:" -{ $subsection dip } ; +} ; + +ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" +"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." +$nl +"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" +{ $code + ": keep [ ] bi ;" + ": 2keep [ ] 2bi ;" + ": 3keep [ ] 3bi ;" + "" + ": dup [ ] [ ] bi ;" + ": 2dup [ ] [ ] 2bi ;" + ": 3dup [ ] [ ] 3bi ;" + "" + ": tuck [ nip ] [ ] 2bi ;" + ": swap [ nip ] [ drop ] 2bi ;" + "" + ": over [ ] [ drop ] 2bi ;" + ": pick [ ] [ 2drop ] 3bi ;" + ": 2over [ ] [ drop ] 3bi ;" +} ; ARTICLE: "cleave-combinators" "Cleave combinators" "The cleave combinators apply multiple quotations to a single value." @@ -49,9 +70,11 @@ $nl "Two quotations:" { $subsection bi } { $subsection 2bi } +{ $subsection 3bi } "Three quotations:" { $subsection tri } { $subsection 2tri } +{ $subsection 3tri } "Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" { $code "! First alternative; uses keep" @@ -66,13 +89,38 @@ $nl "The latter is more aesthetically pleasing than the former." $nl "A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "cleave-shuffle-equivalence" } ; + +ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" +"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "." $nl -"From the Merriam-Webster Dictionary: " -$nl -{ $strong "cleave" } -{ $list - { $emphasis "To divide by or as if by a cutting blow" } - { $emphasis "To separate into distinct parts and especially into groups having divergent views" } +"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" +{ $code + ": dip [ ] bi* ;" + "" + ": slip [ call ] [ ] bi* ;" + ": 2slip [ call ] [ ] [ ] tri* ;" + "" + ": nip [ drop ] [ ] bi* ;" + ": 2nip [ drop ] [ drop ] [ ] tri* ;" + "" + ": rot" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" + "" + ": -rot" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " 3tri ;" + "" + ": spin" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" } ; ARTICLE: "spread-combinators" "Spread combinators" @@ -96,7 +144,8 @@ $nl } $nl -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ; +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "spread-shuffle-equivalence" } ; ARTICLE: "apply-combinators" "Apply combinators" "The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application." diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 319dd1586b..075ce2d0e8 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -267,16 +267,33 @@ $nl } ; ARTICLE: "cookbook-philosophy" "Factor philosophy" -"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write." +"Learning a stack language is like learning to ride a bicycle: it takes a bit of practice and you might graze your knees a couple of times, but once you get the hang of it, it becomes second nature." $nl -"If you try to write Factor word definitions which are longer than a couple of lines, you will find it hard to keep track of the stack contents. Well-written Factor code is " { $emphasis "factored" } " into short definitions, where each definition is easy to test interactively, and has a clear purpose. Well-chosen word names are critical, and having a thesaurus on hand really helps." -$nl -"If you run into problems with stack shuffling, take a deep breath and a step back, and reconsider the problem. A much simpler solution is waiting right around the corner, a natural solution which requires far less stack shuffling and far less code. As a last resort, if no simple solution exists, consider defining a domain-specific language." -$nl -"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition and save yourself some debugging time." -$nl -"In addition to writing short definitions and testing them interactively, a great habit to get into is writing unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } "." +"The most common difficulty encountered by beginners is trouble reading and writing code as a result of trying to place too many values on the stack at a time." $nl +"Keep the following guidelines in mind to avoid losing your sense of balance:" +{ $list + "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines." + "In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code." + "If your code looks repetitive, factor it some more." + "If after factoring, your code still looks repetitive, introduce combinators." + "If after introducing combinators, your code still looks repetitive, look into using meta-programming techniques." + "Try to place items on the stack in the order in which they are needed. If everything is in the correct order, no shuffling needs to be performed." + "If you find yourself writing a stack comment in the middle of a word, break the word up." + { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." } + { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." } + "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition." + { "Learn to use the " { $link "inference" } " tool." } + { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." } + "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution." + { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." } + { "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." } + { "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." } + { "If you find yourself wishing you could iterate over the datastack, or capture the contents of the datastack into a sequence, or push each element of a sequence onto the datastack, there is almost always a better way. Use " { $link "sequences" } " instead." } + "Don't use meta-programming if there's a simpler way." + "Don't worry about efficiency unless your program is too slow. Don't prefer complex code to simple code just because you feel it will be more efficient. The Factor compiler is designed to make idiomatic code run fast." + { "None of the above are hard-and-fast rules: there are exceptions to all of them. But one rule unconditionally holds: " { $emphasis "there is always a simpler way" } "." } +} "Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code." $nl "Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ; From df8dabaf5e56c00fb5eacdb8de167bf6c63d6675 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 08:16:19 -0500 Subject: [PATCH 06/36] Update JSON writer for inheritance --- extra/json/writer/writer.factor | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor index 1741b96e75..6ad0774e38 100644 --- a/extra/json/writer/writer.factor +++ b/extra/json/writer/writer.factor @@ -26,32 +26,27 @@ M: number json-print ( num -- ) M: integer json-print ( num -- ) number>string write ; -M: sequence json-print ( array -- string ) +M: sequence json-print ( array -- ) CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ; -: (jsvar-encode) ( char -- char ) - #! Convert the given character to a character usable in - #! javascript variable names. - dup H{ { CHAR: - CHAR: _ } } at dup [ nip ] [ drop ] if ; - : jsvar-encode ( string -- string ) #! Convert the string so that it contains characters usable within #! javascript variable names. - [ (jsvar-encode) ] map ; + { { CHAR: - CHAR: _ } } substitute ; -: tuple>fields ( object -- string ) +: tuple>fields ( object -- seq ) [ [ swap jsvar-encode >json % " : " % >json % ] "" make ] { } assoc>map ; -M: tuple json-print ( tuple -- string ) +M: tuple json-print ( tuple -- ) CHAR: { write1 tuple>fields "," join write CHAR: } write1 ; -M: hashtable json-print ( hashtable -- string ) +M: hashtable json-print ( hashtable -- ) CHAR: { write1 [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ] { } assoc>map "," join write CHAR: } write1 ; -M: object json-print ( object -- string ) +M: object json-print ( object -- ) unparse json-print ; From 87539b8f4eb4b8be3f3770155dcc9ddf608ceced Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 08:16:30 -0500 Subject: [PATCH 07/36] Clean up db.types --- extra/db/types/types.factor | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 3c73a933e9..9babfbcdb0 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -131,25 +131,17 @@ TUPLE: no-sql-modifier ; HOOK: bind% db ( spec -- ) -TUPLE: no-slot-named ; -: no-slot-named ( -- * ) T{ no-slot-named } throw ; - -: slot-spec-named ( str class -- slot-spec ) - "slots" word-prop [ slot-spec-name = ] with find nip - [ no-slot-named ] unless* ; - : offset-of-slot ( str obj -- n ) - class slot-spec-named slot-spec-offset ; + class "slots" word-prop slot-named slot-spec-offset ; -: get-slot-named ( str obj -- value ) - tuck offset-of-slot [ no-slot-named ] unless* slot ; +: get-slot-named ( name obj -- value ) + tuck offset-of-slot slot ; -: set-slot-named ( value str obj -- ) - tuck offset-of-slot [ no-slot-named ] unless* set-slot ; +: set-slot-named ( value name obj -- ) + tuck offset-of-slot set-slot ; : tuple>filled-slots ( tuple -- alist ) - dup mirror-slots [ slot-spec-name ] map - swap tuple-slots 2array flip [ nip ] assoc-subset ; + [ nip ] assoc-subset ; : tuple>params ( specs tuple -- obj ) [ From 856173f54e20f82ab8eb78e99f58e0c4234b930f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Mar 2008 10:46:07 -0500 Subject: [PATCH 08/36] Add unit test --- extra/io/sockets/sockets-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 extra/io/sockets/sockets-tests.factor diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor new file mode 100644 index 0000000000..1810b8587b --- /dev/null +++ b/extra/io/sockets/sockets-tests.factor @@ -0,0 +1,4 @@ +IN: io.sockets.tests +USING: io.sockets sequences math tools.test ; + +[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test From cb7d655639a412581b8c7036c68ae8141d900f17 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 30 Mar 2008 10:55:47 -0500 Subject: [PATCH 09/36] move addrinfo into *bsd files --- extra/unix/bsd/bsd.factor | 10 ---------- extra/unix/bsd/freebsd/freebsd.factor | 11 +++++++++++ extra/unix/bsd/macosx/macosx.factor | 11 +++++++++++ extra/unix/bsd/netbsd/netbsd.factor | 11 +++++++++++ extra/unix/bsd/openbsd/openbsd.factor | 11 +++++++++++ 5 files changed, 44 insertions(+), 10 deletions(-) diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor index cb7b347c20..6cb5d6385b 100755 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -24,16 +24,6 @@ IN: unix : F_SETFL 4 ; inline : O_NONBLOCK 4 ; inline -C-STRUCT: addrinfo - { "int" "flags" } - { "int" "family" } - { "int" "socktype" } - { "int" "protocol" } - { "socklen_t" "addrlen" } - { "char*" "canonname" } - { "void*" "addr" } - { "addrinfo*" "next" } ; - C-STRUCT: sockaddr-in { "uchar" "len" } { "uchar" "family" } diff --git a/extra/unix/bsd/freebsd/freebsd.factor b/extra/unix/bsd/freebsd/freebsd.factor index 94bb708527..f25cbd1537 100644 --- a/extra/unix/bsd/freebsd/freebsd.factor +++ b/extra/unix/bsd/freebsd/freebsd.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 1024 ; + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "char*" "canonname" } + { "void*" "addr" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/bsd/macosx/macosx.factor b/extra/unix/bsd/macosx/macosx.factor index 3c0617ad17..edef2aaa0c 100644 --- a/extra/unix/bsd/macosx/macosx.factor +++ b/extra/unix/bsd/macosx/macosx.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 1024 ; inline + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "char*" "canonname" } + { "void*" "addr" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/bsd/netbsd/netbsd.factor b/extra/unix/bsd/netbsd/netbsd.factor index ac18749830..071daa682d 100644 --- a/extra/unix/bsd/netbsd/netbsd.factor +++ b/extra/unix/bsd/netbsd/netbsd.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 256 ; inline + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "char*" "canonname" } + { "void*" "addr" } + { "addrinfo*" "next" } ; diff --git a/extra/unix/bsd/openbsd/openbsd.factor b/extra/unix/bsd/openbsd/openbsd.factor index 3c0617ad17..29b44f7da6 100644 --- a/extra/unix/bsd/openbsd/openbsd.factor +++ b/extra/unix/bsd/openbsd/openbsd.factor @@ -1,3 +1,14 @@ +USING: alien.syntax ; IN: unix : FD_SETSIZE 1024 ; inline + +C-STRUCT: addrinfo + { "int" "flags" } + { "int" "family" } + { "int" "socktype" } + { "int" "protocol" } + { "socklen_t" "addrlen" } + { "void*" "addr" } + { "char*" "canonname" } + { "addrinfo*" "next" } ; From d367dc8462397b6de8f162098516d57b18533959 Mon Sep 17 00:00:00 2001 From: sheeple Date: Sun, 30 Mar 2008 12:21:44 -0500 Subject: [PATCH 10/36] fix gdb on freebsd --- extra/tools/disassembler/disassembler.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 479ae9c42c..927f7111fa 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -26,11 +26,14 @@ M: pair make-disassemble-cmd M: method-spec make-disassemble-cmd first2 method make-disassemble-cmd ; +: gdb-binary ( -- string ) + os "freebsd" = "gdb66" "gdb" ? ; + : run-gdb ( -- lines ) +closed+ >>stdin out-file >>stdout - [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command + [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command try-process out-file ascii file-lines ; From 71283f7fc59ca52e8b63ebae8320d0cdbc79e529 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 17:21:58 -0500 Subject: [PATCH 11/36] Documentation update --- core/kernel/kernel-docs.factor | 39 +++++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 1c88f5a485..b1120de8e6 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -545,7 +545,7 @@ HELP: 2bi "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- z )" } ", then the following two lines are equivalent:" { $code "[ p ] [ q ] 2bi" - "2dup p swap q" + "2dup p -rot q" } "In general, the following two lines are equivalent:" { $code @@ -554,6 +554,27 @@ HELP: 2bi } } ; +HELP: 3bi +{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." } +{ $examples + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] 3bi" + "3dup p q" + } + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] 3bi" + "3dup p -roll q" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] 3bi" + "[ p ] 3keep q" + } +} ; + HELP: tri { $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } } { $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." } @@ -591,6 +612,22 @@ HELP: 2tri } } ; +HELP: 3tri +{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." } +{ $examples + "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 3tri" + "3dup p 3dup q r" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 3tri" + "[ p ] 3keep [ q ] 3keep r" + } +} ; + HELP: bi* { $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } } From cd85b545bd28d0c1cde36376a2f60acc98a1cf12 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 17:23:42 -0500 Subject: [PATCH 12/36] Cleaning up tuples --- core/classes/tuple/tuple.factor | 99 ++++++++++++++++++++------------- core/slots/slots.factor | 3 - 2 files changed, 59 insertions(+), 43 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index a452d0eeec..401a421c51 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -23,8 +23,15 @@ M: class tuple-layout "layout" word-prop ; M: tuple tuple-layout 1 slot ; +M: tuple-layout tuple-layout ; : tuple-size tuple-layout layout-size ; inline +: prepare-tuple>array ( tuple -- n tuple layout ) + [ tuple-size ] [ ] [ tuple-layout ] tri ; + +: copy-tuple-slots ( n tuple first -- array ) + [ array-nth ] curry map r> add* ; + PRIVATE> : check-tuple ( class -- ) @@ -32,28 +39,29 @@ PRIVATE> [ drop ] [ no-tuple-class ] if ; : tuple>array ( tuple -- array ) - dup tuple-layout - [ layout-size swap [ array-nth ] curry map ] keep - layout-class add* ; + prepare-tuple>array >r copy-tuple-slots r> layout-class add* ; -: >tuple ( seq -- tuple ) - dup first tuple-layout [ - >r 1 tail-slice dup length r> - [ tuple-size min ] keep - [ set-array-nth ] curry - 2each +: tuple-slots ( tuple -- array ) + prepare-tuple>array drop copy-tuple-slots ; + +: slots>tuple ( tuple class -- array ) + tuple-layout [ + [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each ] keep ; +: >tuple ( tuple -- array ) + unclip slots>tuple ; + : slot-names ( class -- seq ) - "slots" word-prop [ name>> ] map ; + "slot-names" word-prop ; r over r> array-nth >r array-nth r> = ] 2curry - all-integers? + 2dup [ tuple-layout ] bi@ eq? [ + [ drop tuple-size ] + [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ] + 2bi all-integers? ] [ 2drop f ] if ; @@ -92,18 +100,19 @@ PRIVATE> superclasses 1 head-slice* [ slot-names length ] map sum ; -: generate-tuple-slots ( class slots -- slots ) +: generate-tuple-slots ( class slots -- slot-specs ) over superclass-size 2 + simple-slots ; -: define-tuple-slots ( class slots -- ) - dupd generate-tuple-slots +: define-tuple-slots ( class -- ) + dup dup slot-names generate-tuple-slots [ "slots" set-word-prop ] - [ define-accessors ] - [ define-slots ] 2tri ; + [ define-accessors ] ! new + [ define-slots ] ! old + 2tri ; : make-tuple-layout ( class -- layout ) [ ] - [ [ superclass-size ] [ "slots" word-prop length ] bi + ] + [ [ superclass-size ] [ slot-names length ] bi + ] [ superclasses dup length 1- ] tri ; @@ -113,7 +122,7 @@ PRIVATE> : removed-slots ( class newslots -- seq ) swap slot-names seq-diff ; -: forget-slots ( class slots -- ) +: forget-removed-slots ( class slots -- ) dupd removed-slots [ [ reader-word forget-method ] [ writer-word forget-method ] 2bi @@ -122,36 +131,48 @@ PRIVATE> : permutation ( seq1 seq2 -- permutation ) swap [ index ] curry map ; -: reshape-tuple ( oldtuple permutation -- newtuple ) - >r tuple>array 2 cut r> - [ [ swap ?nth ] [ drop f ] if* ] with map - append >tuple ; +: all-slot-names ( class -- slots ) + superclasses [ slot-names ] map concat \ class add* ; -: reshape-tuples ( class superclass newslots -- ) - nip - >r dup slot-names r> permutation - [ - >r "predicate" word-prop instances dup - r> [ reshape-tuple ] curry map - become - ] 2curry after-compilation ; +: slot-permutation ( class superclass newslots -- n permutation ) + [ all-slot-names ] [ all-slot-names ] [ ] tri* append + [ drop length ] [ permutation ] 2bi ; + +: permute-direct-slots ( oldslots permutation -- newslots ) + [ [ swap ?nth ] [ drop f ] if* ] with map ; + +: permute-all-slots ( oldslots n permutation -- newslots ) + [ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ; + +: change-tuple ( tuple quot -- newtuple ) + >r tuple>array r> call >tuple ; inline + +: update-tuples ( predicate n permutation -- ) + [ permute-all-slots ] 2curry [ change-tuple ] curry + >r "predicate" word-prop instances dup r> map + become ; inline + +: update-tuples-after ( class superclass newslots -- ) + [ 2drop ] [ slot-permutation ] 3bi + [ update-tuples ] 3curry after-compilation ; : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] - [ nip define-tuple-slots ] [ + [ nip "slot-names" set-word-prop ] [ 2drop class-usages keys [ tuple-class? ] subset [ + [ define-tuple-slots ] [ define-tuple-layout ] [ define-tuple-predicate ] - bi + tri ] each ] 3tri ; : redefine-tuple-class ( class superclass slots -- ) - [ reshape-tuples ] + [ update-tuples-after ] [ nip - [ forget-slots ] + [ forget-removed-slots ] [ drop changed-word ] [ drop redefined ] 2tri @@ -175,7 +196,7 @@ M: tuple-class define-tuple-class 3drop ; : define-error-class ( class superclass slots -- ) - pick >r define-tuple-class r> + [ define-tuple-class ] [ 2drop ] 3bi dup [ construct-boa throw ] curry define ; M: tuple clone @@ -196,8 +217,6 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -: tuple-slots ( tuple -- seq ) tuple>array 2 tail ; - ! Definition protocol M: tuple-class reset-class { "metaclass" "superclass" "slots" "layout" } reset-props ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index dfd5c1b32a..eeb0926308 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -23,9 +23,6 @@ C: slot-spec [ drop ] [ 1array , \ declare , ] if ] [ ] make ; -: slot-named ( name specs -- spec/f ) - [ slot-spec-name = ] with find nip ; - : create-accessor ( name effect -- word ) >r "accessors" create dup r> "declared-effect" set-word-prop ; From c30a8a68ee6216b3140836e9f77c7306f48a5111 Mon Sep 17 00:00:00 2001 From: erg Date: Sun, 30 Mar 2008 18:22:35 -0500 Subject: [PATCH 13/36] refactor mersenne-twister to not use new-effects --- .../mersenne-twister/mersenne-twister.factor | 38 ++++++++++--------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index ad9dae51ae..4c4bc8286f 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,11 +4,14 @@ ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c USING: arrays kernel math namespaces sequences system init -accessors math.ranges new-effects random ; +accessors math.ranges random ; IN: random.mersenne-twister r over r> [ curry ] 2bi@ ; + TUPLE: mersenne-twister seq i ; : mt-n 624 ; inline @@ -19,34 +22,33 @@ TUPLE: mersenne-twister seq i ; : wrap ( x n -- y ) 2dup >= [ - ] [ drop ] if ; inline : mt-wrap ( x -- y ) mt-n wrap ; inline -: set-generated ( mt y from-elt to -- ) - >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi - r> bitxor bitxor r> new-set-nth drop ; inline +: set-generated ( y from-elt to seq -- ) + >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi + r> bitxor bitxor r> r> set-nth ; inline -: calculate-y ( mt y1 y2 -- y ) - >r over r> - [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline +: calculate-y ( y1 y2 mt -- y ) + [ nth mt-hi ] [ nth mt-lo ] curry2 bi* bitor ; inline -: (mt-generate) ( mt-seq n -- y to from-elt ) - [ dup 1+ mt-wrap calculate-y ] - [ mt-m + mt-wrap new-nth ] - [ nip ] 2tri ; +: (mt-generate) ( n mt-seq -- y to from-elt ) + [ >r dup 1+ mt-wrap r> calculate-y ] + [ >r mt-m + mt-wrap r> nth ] + [ drop ] 2tri ; : mt-generate ( mt -- ) - [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ] + [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ] [ 0 >>i drop ] bi ; : init-mt-first ( seed -- seq ) >r mt-n 0 r> - HEX: ffffffff bitand 0 new-set-nth ; + HEX: ffffffff bitand 0 pick set-nth ; : init-mt-formula ( seq i -- f(seq[i]) ) - tuck new-nth dup -30 shift bitxor 1812433253 * + + tuck swap nth dup -30 shift bitxor 1812433253 * + 1+ HEX: ffffffff bitand ; : init-mt-rest ( seq -- ) mt-n 1- [0,b) [ - dupd [ init-mt-formula ] keep 1+ new-set-nth drop + dupd [ init-mt-formula ] keep 1+ rot set-nth ] with each ; : init-mt-seq ( seed -- seq ) @@ -68,7 +70,7 @@ M: mersenne-twister seed-random ( mt seed -- ) init-mt-seq >>seq drop ; M: mersenne-twister random-32* ( mt -- r ) - dup [ seq>> ] [ i>> ] bi - dup mt-n < [ drop 0 pick mt-generate ] unless - new-nth mt-temper + dup [ i>> ] [ seq>> ] bi + over mt-n < [ nip >r dup mt-generate 0 r> ] unless + nth mt-temper swap [ 1+ ] change-i drop ; From 55a69392faadff0988a49696f734562491e484d0 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 13:52:42 +1300 Subject: [PATCH 14/36] First cut at variables in ebnf --- extra/peg/ebnf/ebnf.factor | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 41b5a1b655..e9ec0dc4e2 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -3,7 +3,7 @@ USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg peg.parsers unicode.categories multiline combinators.lib - splitting accessors effects ; + splitting accessors effects sequences.deep ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -227,15 +227,17 @@ GENERIC: (transform) ( ast -- parser ) SYMBOL: parser SYMBOL: main +SYMBOL: vars : transform ( ast -- object ) - H{ } clone dup dup [ parser set swap (transform) main set ] bind ; + H{ } clone dup dup [ parser set V{ } vars set swap (transform) main set ] bind ; M: ebnf (transform) ( ast -- parser ) rules>> [ (transform) ] map peek ; M: ebnf-rule (transform) ( ast -- parser ) - dup elements>> (transform) [ + dup elements>> + vars get clone vars [ (transform) ] with-variable [ swap symbol>> set ] keep ; @@ -270,12 +272,26 @@ M: ebnf-repeat1 (transform) ( ast -- parser ) M: ebnf-optional (transform) ( ast -- parser ) transform-group optional ; +: build-locals ( string vars -- string ) + dup empty? [ + drop + ] [ + [ + "[let* | " % + [ dup % " [ \"" % % "\" get ] " % ] each + " | " % + % + " ] with-locals" % + ] "" make + ] if ; + M: ebnf-action (transform) ( ast -- parser ) [ parser>> (transform) ] keep - code>> string-lines [ parse-lines ] with-compilation-unit action ; + code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ; M: ebnf-var (transform) ( ast -- parser ) - parser>> (transform) ; + [ parser>> (transform) ] [ name>> ] bi + dup vars get push [ dupd set ] curry action ; M: ebnf-terminal (transform) ( ast -- parser ) symbol>> token sp ; @@ -303,7 +319,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : ebnf>quot ( string -- hashtable quot ) 'ebnf' parse check-parse-result parse-result-ast transform dup dup parser [ main swap at compile ] with-variable - [ compiled-parse ] curry ; + [ compiled-parse ] curry [ with-scope ] curry ; : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing From a098790634503dfc03eb24969a4fbaff7f7512f5 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 30 Mar 2008 17:58:47 -0700 Subject: [PATCH 15/36] Updated extra/match to use bi@ instead of 2apply. Ran "peg" test for testing. --- extra/match/match.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/match/match.factor b/extra/match/match.factor index dbc42f53e3..825d58c7c2 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -70,7 +70,7 @@ MACRO: match-cond ( assoc -- ) dup length zero? not [ 1 tail ] [ drop f ] if ; : (match-first) ( seq pattern-seq -- bindings leftover/f ) - 2dup [ length ] 2apply < [ 2drop f f ] + 2dup [ length ] bi@ < [ 2drop f f ] [ 2dup length head over match [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if* From ee2194d1dc1eb4df9072dae9ce50a9bb13353b98 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 14:03:16 +1300 Subject: [PATCH 16/36] Allow variable names on elements --- extra/peg/ebnf/ebnf.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e9ec0dc4e2..f98b08093a 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -102,7 +102,7 @@ C: ebnf "]" syntax , ] seq* [ first >string ] action ; -: 'element' ( -- parser ) +: ('element') ( -- parser ) #! An element of a rule. It can be a terminal or a #! non-terminal but must not be followed by a "=". #! The latter indicates that it is the beginning of a @@ -120,6 +120,12 @@ C: ebnf ] choice* , ] seq* [ first ] action ; +: 'element' ( -- parser ) + [ + [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 ] action , + ('element') , + ] choice* ; + DEFER: 'choice' : grouped ( quot suffix -- parser ) From 729ac1d6dc18ddfd26aebae44d27c6ea62eec767 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 14:59:22 +1300 Subject: [PATCH 17/36] Some ebnf tweaks and tests to do with variables --- extra/peg/ebnf/ebnf-tests.factor | 9 ++++++++- extra/peg/ebnf/ebnf.factor | 2 +- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 7aa61e84da..cf16fad2cd 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.ebnf words ; +USING: kernel tools.test peg peg.ebnf words math math.parser ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ @@ -160,6 +160,13 @@ IN: peg.ebnf.tests "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast ] unit-test +{ 6 } [ + "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call parse-result-ast +] unit-test + +{ 6 } [ + "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast +] unit-test { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index f98b08093a..74b3e3540d 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -283,7 +283,7 @@ M: ebnf-optional (transform) ( ast -- parser ) drop ] [ [ - "[let* | " % + "USING: locals namespaces ; [let* | " % [ dup % " [ \"" % % "\" get ] " % ] each " | " % % From c45eba68987e41ad14e0cc817079801e713af1b8 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 16:34:59 +1300 Subject: [PATCH 18/36] Add semantic parser --- extra/peg/peg-docs.factor | 13 +++++++++++++ extra/peg/peg.factor | 20 ++++++++++++++++++++ 2 files changed, 33 insertions(+) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index e7bd255569..c54a39b7b0 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -95,6 +95,19 @@ HELP: optional "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is " "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ; +HELP: semantic +{ $values + { "parser" "a parser" } + { "quot" "a quotation with stack effect ( object -- bool )" } +} +{ $description + "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with " + "the AST produced by 'p1' on the stack returns true." } +{ $examples + { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" } + { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" } +} ; + HELP: ensure { $values { "parser" "a parser" } diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 43eb9e8d9e..9e35c5b9be 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -414,6 +414,23 @@ TUPLE: optional-parser p1 ; M: optional-parser (compile) ( parser -- quot ) p1>> compiled-parser \ ?quot optional-pattern match-replace ; +TUPLE: semantic-parser p1 quot ; + +MATCH-VARS: ?parser ; + +: semantic-pattern ( -- quot ) + [ + ?parser [ + dup parse-result-ast ?quot call [ drop f ] unless + ] [ + f + ] if* + ] ; + +M: semantic-parser (compile) ( parser -- quot ) + [ p1>> compiled-parser ] [ quot>> ] bi + 2array { ?parser ?quot } semantic-pattern match-replace ; + TUPLE: ensure-parser p1 ; : ensure-pattern ( -- quot ) @@ -546,6 +563,9 @@ PRIVATE> : optional ( parser -- parser ) optional-parser construct-boa init-parser ; +: semantic ( parser quot -- parser ) + semantic-parser construct-boa init-parser ; + : ensure ( parser -- parser ) ensure-parser construct-boa init-parser ; From 8aa676ab1eda35b0d6011fbbb2689e12215664f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 22:42:36 -0500 Subject: [PATCH 19/36] Documentation fixes --- core/continuations/continuations-docs.factor | 1 + core/debugger/debugger-docs.factor | 10 +++++++++- extra/help/handbook/handbook.factor | 1 + extra/help/markup/markup.factor | 3 +-- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7209b7ec4d..ca7af930f2 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -29,6 +29,7 @@ $nl { $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } +{ $subsection "debugger" } { $subsection "errors-post-mortem" } "When Factor encouters a critical error, it calls the following word:" { $subsection die } ; diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index 5e8b6df34a..f8b53d4abc 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -86,7 +86,15 @@ HELP: error-hook HELP: try { $values { "quot" "a quotation" } } -{ $description "Calls the quotation. If it throws an error, calls " { $link error-hook } " with the error and restores the data stack." } ; +{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." } +{ $examples + "The following example prints an error and keeps going:" + { $code + "[ \"error\" throw ] try" + "\"still running...\" print" + } + { $link "listener" } " uses " { $link try } " to recover from user errors." +} ; HELP: expired-error. { $error-description "Thrown by " { $link alien-address } " and " { $link alien-invoke } " if an " { $link alien } " object passed in as a parameter has expired. Alien objects expire if they are saved an image which is subsequently loaded; this prevents a certain class of programming errors, usually attempts to use uninitialized objects, since holding a C address is meaningless between sessions." } diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 912c3c35f3..1c2dfde85c 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -206,6 +206,7 @@ ARTICLE: "tools" "Developer tools" { $subsection "tools.vocabs" } "Exploratory tools:" { $subsection "editor" } +{ $subsection "listener" } { $subsection "tools.crossref" } { $subsection "inspector" } "Debugging tools:" diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 5dc7255eed..f8d360fd0a 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -138,8 +138,7 @@ M: f print-element drop ; link-style get [ write-object ] with-style ; : ($link) ( article -- ) - dup article-name swap >link write-link - span last-element set ; + [ dup article-name swap >link write-link ] ($span) ; : $link ( element -- ) first ($link) ; From f66774e87564aa5f6d66f80dd00c72b2db456700 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 16:50:05 +1300 Subject: [PATCH 20/36] Add tests for semantic and add syntax for it to ebnf Syntax is ?[ ...]? For example: [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] { 1 2 3 4 5 6 } swap call . --- extra/peg/ebnf/ebnf-tests.factor | 12 ++++++++++++ extra/peg/ebnf/ebnf.factor | 16 ++++++++++++---- extra/peg/peg-tests.factor | 13 +++++++++++-- 3 files changed, 35 insertions(+), 6 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index cf16fad2cd..4f802c5207 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -168,6 +168,18 @@ IN: peg.ebnf.tests "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast ] unit-test +{ 10 } [ + { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast +] unit-test + +{ f } [ + { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call +] unit-test + +{ 3 } [ + { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast +] unit-test + { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 74b3e3540d..4f00edbd3c 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -20,6 +20,7 @@ TUPLE: ebnf-optional group ; TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-action parser code ; TUPLE: ebnf-var parser name ; +TUPLE: ebnf-semantic parser code ; TUPLE: ebnf rules ; C: ebnf-non-terminal @@ -36,6 +37,7 @@ C: ebnf-optional C: ebnf-rule C: ebnf-action C: ebnf-var +C: ebnf-semantic C: ebnf : syntax ( string -- parser ) @@ -156,6 +158,7 @@ DEFER: 'choice' : 'factor-code' ( -- parser ) [ "]]" token ensure-not , + "]?" token ensure-not , [ drop t ] satisfy , ] seq* [ first ] action repeat0 [ >string ] action ; @@ -193,14 +196,15 @@ DEFER: 'choice' : 'action' ( -- parser ) "[[" 'factor-code' "]]" syntax-pack ; +: 'semantic' ( -- parser ) + "?[" 'factor-code' "]?" syntax-pack ; + : 'sequence' ( -- parser ) #! A sequence of terminals and non-terminals, including #! groupings of those. [ - [ - ('sequence') , - 'action' , - ] seq* [ first2 ] action , + [ ('sequence') , 'action' , ] seq* [ first2 ] action , + [ ('sequence') , 'semantic' , ] seq* [ first2 ] action , ('sequence') , ] choice* repeat1 [ dup length 1 = [ first ] [ ] if @@ -295,6 +299,10 @@ M: ebnf-action (transform) ( ast -- parser ) [ parser>> (transform) ] keep code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ; +M: ebnf-semantic (transform) ( ast -- parser ) + [ parser>> (transform) ] keep + code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ; + M: ebnf-var (transform) ( ast -- parser ) [ parser>> (transform) ] [ name>> ] bi dup vars get push [ dupd set ] curry action ; diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index f57fe83220..fcec33f7c2 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words ; +USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ; IN: peg.tests { f } [ @@ -182,4 +182,13 @@ IN: peg.tests [ f , "a" token , ] seq* dup parsers>> dupd 0 swap set-nth compile word? -] unit-test \ No newline at end of file +] unit-test + +{ f } [ + "A" [ drop t ] satisfy [ 66 >= ] semantic parse +] unit-test + +{ CHAR: B } [ + "B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast +] unit-test + From a41f8ef7338d565329ca8d0cb646e3746032ccd2 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 31 Mar 2008 17:26:42 +1300 Subject: [PATCH 21/36] Mention how to fail from action in pegs --- extra/peg/peg-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index c54a39b7b0..5f200be78e 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -137,7 +137,7 @@ HELP: action "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting " "from that parse. The result of the quotation is then used as the final AST. This can be used " "for manipulating the parse tree to produce a AST better suited for the task at hand rather than " - "the default AST." } + "the default AST. If the quotation returns " { $link fail } " then the parser fails." } { $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ; HELP: sp From d87667f903c3dd33fda10e5cc8a74fc3cc0e02de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Mar 2008 23:54:57 -0500 Subject: [PATCH 22/36] Add inline declaration --- extra/random/mersenne-twister/mersenne-twister.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 4c4bc8286f..ce1749ce62 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -10,7 +10,7 @@ IN: random.mersenne-twister r over r> [ curry ] 2bi@ ; + >r over r> [ curry ] 2bi@ ; inline TUPLE: mersenne-twister seq i ; From 2ebb7d22718b1b1e90943c5fd35a6a4915fb4e34 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 01:19:21 -0500 Subject: [PATCH 23/36] Clean up bootstrap code a bit --- core/bootstrap/image/image.factor | 116 ++++++++++++++---------------- core/bootstrap/primitives.factor | 49 +++++++------ 2 files changed, 84 insertions(+), 81 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index deb54fdeeb..5d49203554 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -12,7 +12,7 @@ io.encodings.binary ; IN: bootstrap.image : my-arch ( -- arch ) - cpu dup "ppc" = [ os "-" rot 3append ] when ; + cpu dup "ppc" = [ >r os "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; @@ -55,7 +55,7 @@ IN: bootstrap.image : quot-xt@ 3 bootstrap-cells object tag-number - ; : jit-define ( quot rc rt offset name -- ) - >r >r >r >r { } make r> r> r> 4array r> set ; + >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ; ! The image being constructed; a vector of word-size integers SYMBOL: image @@ -134,10 +134,10 @@ SYMBOL: undefined-quot : here ( -- size ) heap-size data-base + ; -: here-as ( tag -- pointer ) here swap bitor ; +: here-as ( tag -- pointer ) here bitor ; : align-here ( -- ) - here 8 mod 4 = [ heap-size drop 0 emit ] when ; + here 8 mod 4 = [ 0 emit ] when ; : emit-fixnum ( n -- ) tag-fixnum emit ; @@ -164,7 +164,7 @@ GENERIC: ' ( obj -- ptr ) userenv-size [ f ' emit ] times ; : emit-userenv ( symbol -- ) - dup get ' swap userenv-offset fixup ; + [ get ' ] [ userenv-offset ] bi fixup ; ! Bignums @@ -175,14 +175,15 @@ GENERIC: ' ( obj -- ptr ) : bignum>seq ( n -- seq ) #! n is positive or zero. [ dup 0 > ] - [ dup bignum-bits neg shift swap bignum-radix bitand ] + [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ] [ ] unfold nip ; -USE: continuations : emit-bignum ( n -- ) - dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq - dup length 1+ emit-fixnum - swap emit emit-seq ; + dup dup 0 < [ neg ] when bignum>seq + [ nip length 1+ emit-fixnum ] + [ drop 0 < 1 0 ? emit ] + [ nip emit-seq ] + 2tri ; M: bignum ' bignum tag-number dup [ emit-bignum ] emit-object ; @@ -221,28 +222,33 @@ M: f ' ! Words : emit-word ( word -- ) - dup subwords [ emit-word ] each [ - dup hashcode ' , - dup word-name ' , - dup word-vocabulary ' , - dup word-def ' , - dup word-props ' , - f ' , - 0 , ! count - 0 , ! xt - 0 , ! code - 0 , ! profiling - ] { } make - \ word type-number object tag-number - [ emit-seq ] emit-object - swap objects get set-at ; + [ subwords [ emit-word ] each ] + [ + [ + { + [ hashcode , ] + [ word-name , ] + [ word-vocabulary , ] + [ word-def , ] + [ word-props , ] + } cleave + f , + 0 , ! count + 0 , ! xt + 0 , ! code + 0 , ! profiling + ] { } make [ ' ] map + ] bi + \ word type-number object tag-number + [ emit-seq ] emit-object + ] keep objects get set-at ; : word-error ( word msg -- * ) [ % dup word-vocabulary % " " % word-name % ] "" make throw ; : transfer-word ( word -- word ) - dup target-word swap or ; + [ target-word ] keep or ; : fixup-word ( word -- offset ) transfer-word dup objects get at @@ -285,9 +291,10 @@ M: string ' length 0 assert= ; : emit-dummy-array ( obj type -- ptr ) - swap assert-empty - type-number object tag-number - [ 0 emit-fixnum ] emit-object ; + [ assert-empty ] [ + type-number object tag-number + [ 0 emit-fixnum ] emit-object + ] bi* ; M: byte-array ' byte-array emit-dummy-array ; @@ -296,29 +303,28 @@ M: bit-array ' bit-array emit-dummy-array ; M: float-array ' float-array emit-dummy-array ; ! Tuples +: (emit-tuple) ( tuple -- pointer ) + [ tuple>array 1 tail-slice ] + [ class transfer-word tuple-layout ] bi add* [ ' ] map + tuple type-number dup [ emit-seq ] emit-object ; + : emit-tuple ( tuple -- pointer ) - [ - [ - dup class transfer-word tuple-layout ' , - tuple>array 1 tail-slice [ ' ] map % - ] { } make - tuple type-number dup [ emit-seq ] emit-object - ] - ! Hack - over class word-name "tombstone" = - [ objects get swap cache ] [ call ] if ; + dup class word-name "tombstone" = + [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ; M: tuple ' emit-tuple ; M: tuple-layout ' objects get [ [ - dup layout-hashcode ' , - dup layout-class ' , - dup layout-size ' , - dup layout-superclasses ' , - layout-echelon ' , - ] { } make + { + [ layout-hashcode , ] + [ layout-class , ] + [ layout-size , ] + [ layout-superclasses , ] + [ layout-echelon , ] + } cleave + ] { } make [ ' ] map \ tuple-layout type-number object tag-number [ emit-seq ] emit-object ] cache ; @@ -329,14 +335,9 @@ M: tombstone ' word-def first objects get [ emit-tuple ] cache ; ! Arrays -: emit-array ( list type tag -- pointer ) - >r >r [ ' ] map r> r> [ - dup length emit-fixnum - emit-seq - ] emit-object ; - M: array ' - array type-number object tag-number emit-array ; + [ ' ] map array type-number object tag-number + [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; ! Quotations @@ -351,13 +352,6 @@ M: quotation ' ] emit-object ] cache ; -! Curries - -M: curry ' - dup curry-quot ' swap curry-obj ' - \ curry type-number object tag-number - [ emit emit ] emit-object ; - ! End of the image : emit-words ( -- ) @@ -437,8 +431,8 @@ M: curry ' : write-image ( image -- ) "Writing image to " write architecture get boot-image-name resource-path - dup write "..." print flush - binary [ (write-image) ] with-stream ; + [ write "..." print flush ] + [ binary [ (write-image) ] with-stream ] bi ; PRIVATE> diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 2e1a7f9f57..bc876c2dec 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -5,7 +5,8 @@ hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes classes.tuple classes.tuple.private kernel.private vocabs vocabs.loader source-files definitions slots.deprecated -classes.union compiler.units bootstrap.image.private io.files ; +classes.union compiler.units bootstrap.image.private io.files +accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -102,33 +103,36 @@ num-types get f builtins set ! Builtin classes : builtin-predicate-quot ( class -- quot ) [ - "type" word-prop dup - \ tag-mask get < \ tag \ type ? , , \ eq? , + "type" word-prop + [ tag-mask get < \ tag \ type ? , ] [ , ] bi + \ eq? , ] [ ] make ; : define-builtin-predicate ( class -- ) - dup - dup builtin-predicate-quot define-predicate - predicate-word make-inline ; + [ dup builtin-predicate-quot define-predicate ] + [ predicate-word make-inline ] + bi ; : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; : register-builtin ( class -- ) - dup - dup lookup-type-number "type" set-word-prop - dup "type" word-prop builtins get set-nth ; + [ dup lookup-type-number "type" set-word-prop ] + [ dup "type" word-prop builtins get set-nth ] + bi ; : define-builtin-slots ( symbol slotspec -- ) - dupd 1 simple-slots - 2dup "slots" set-word-prop - define-slots ; + [ drop ] [ 1 simple-slots ] 2bi + [ "slots" set-word-prop ] [ define-slots ] 2bi ; : define-builtin ( symbol slotspec -- ) >r - dup register-builtin - dup f f builtin-class define-class - dup define-builtin-predicate + { + [ register-builtin ] + [ f f builtin-class define-class ] + [ define-builtin-predicate ] + [ ] + } cleave r> define-builtin-slots ; ! Forward definitions @@ -335,7 +339,10 @@ define-builtin { "set-delegate" "kernel" } } } -define-tuple-slots +[ drop ] [ generate-tuple-slots ] 2bi +[ [ name>> ] map "slot-names" set-word-prop ] +[ "slots" set-word-prop ] +[ define-slots ] 2tri "tuple" "kernel" lookup define-tuple-layout @@ -495,8 +502,9 @@ f builtins get num-tags get tail union-class define-class } define-tuple-class "curry" "kernel" lookup -dup f "inline" set-word-prop -dup tuple-layout [ ] curry define +[ f "inline" set-word-prop ] +[ ] +[ tuple-layout [ ] curry ] tri define "compose" "kernel" create "tuple" "kernel" lookup @@ -515,8 +523,9 @@ dup tuple-layout [ ] curry define } define-tuple-class "compose" "kernel" lookup -dup f "inline" set-word-prop -dup tuple-layout [ ] curry define +[ f "inline" set-word-prop ] +[ ] +[ tuple-layout [ ] curry ] tri define ! Primitive words : make-primitive ( word vocab n -- ) From 6995e2adf5535194440fe5cac34087da2efda99e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 01:19:34 -0500 Subject: [PATCH 24/36] Tuple reshaping now works with inheritance --- core/classes/tuple/tuple-docs.factor | 14 +---- core/classes/tuple/tuple-tests.factor | 88 +++++++++++++++++++++++--- core/classes/tuple/tuple.factor | 90 ++++++++++++++++----------- core/compiler/units/units.factor | 14 ++--- core/slots/slots.factor | 3 + 5 files changed, 142 insertions(+), 67 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 7123d5c7c8..18c8143654 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -153,23 +153,11 @@ HELP: tuple= { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } { $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ; -HELP: permutation -{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } } -{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ; - -HELP: reshape-tuple -{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } } -{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ; - -HELP: reshape-tuples -{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } } -{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ; - HELP: removed-slots { $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } } { $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ; -HELP: forget-slots +HELP: forget-removed-slots { $values { "class" tuple-class } { "slots" "a sequence of strings" } } { $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 9b8228155b..0fac0c3779 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -265,9 +265,13 @@ 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 +: test-laptop-slot-values + [ laptop ] [ "laptop" get class ] unit-test + [ "Pentium" ] [ "laptop" get cpu>> ] unit-test + [ 128 ] [ "laptop" get ram>> ] unit-test + [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ; + +test-laptop-slot-values [ laptop ] [ "laptop" get tuple-layout @@ -294,9 +298,13 @@ C: server [ 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 +: test-server-slot-values + [ server ] [ "server" get class ] unit-test + [ "PowerPC" ] [ "server" get cpu>> ] unit-test + [ 64 ] [ "server" get ram>> ] unit-test + [ "1U" ] [ "server" get rackmount>> ] unit-test ; + +test-server-slot-values [ f ] [ "server" get laptop? ] unit-test [ f ] [ "laptop" get server? ] unit-test @@ -316,10 +324,10 @@ C: server "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval ] must-fail -! Reshaping with inheritance +! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test [ f ] [ electronic-device laptop class< ] unit-test [ t ] [ server electronic-device class< ] unit-test @@ -335,11 +343,73 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +TUPLE: make-me-some-accessors voltage grounded? ; + +[ f ] [ "laptop" get voltage>> ] unit-test +[ f ] [ "server" get voltage>> ] unit-test + +[ ] [ "laptop" get 220 >>voltage drop ] unit-test +[ ] [ "server" get 110 >>voltage drop ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +[ 220 ] [ "laptop" get voltage>> ] unit-test +[ 110 ] [ "server" get voltage>> ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +[ 220 ] [ "laptop" get voltage>> ] unit-test +[ 110 ] [ "server" get voltage>> ] unit-test + +! Reshaping superclass and subclass simultaneously +"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval + +test-laptop-slot-values +test-server-slot-values + +[ 220 ] [ "laptop" get voltage>> ] unit-test +[ 110 ] [ "server" get voltage>> ] unit-test + +! Reshape crash +TUPLE: test1 a ; TUPLE: test2 < test1 b ; + +T{ test2 f "a" "b" } "test" set + +: test-a/b + [ "a" ] [ "test" get a>> ] unit-test + [ "b" ] [ "test" get b>> ] unit-test ; + +test-a/b + +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test + +test-a/b + +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test + +test-a/b + ! Redefinition problem TUPLE: redefinition-problem ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 401a421c51..158ea9fc55 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -24,13 +24,14 @@ M: class tuple-layout "layout" word-prop ; M: tuple tuple-layout 1 slot ; M: tuple-layout tuple-layout ; + : tuple-size tuple-layout layout-size ; inline : prepare-tuple>array ( tuple -- n tuple layout ) [ tuple-size ] [ ] [ tuple-layout ] tri ; -: copy-tuple-slots ( n tuple first -- array ) - [ array-nth ] curry map r> add* ; +: copy-tuple-slots ( n tuple -- array ) + [ array-nth ] curry map ; PRIVATE> @@ -128,48 +129,63 @@ PRIVATE> [ writer-word forget-method ] 2bi ] with each ; -: permutation ( seq1 seq2 -- permutation ) - swap [ index ] curry map ; - : all-slot-names ( class -- slots ) superclasses [ slot-names ] map concat \ class add* ; -: slot-permutation ( class superclass newslots -- n permutation ) - [ all-slot-names ] [ all-slot-names ] [ ] tri* append - [ drop length ] [ permutation ] 2bi ; +: compute-slot-permutation ( class old-slot-names -- permutation ) + >r all-slot-names r> [ index ] curry map ; -: permute-direct-slots ( oldslots permutation -- newslots ) +: apply-slot-permutation ( old-values permutation -- new-values ) [ [ swap ?nth ] [ drop f ] if* ] with map ; -: permute-all-slots ( oldslots n permutation -- newslots ) - [ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ; +: permute-slots ( old-values -- new-values ) + dup first dup outdated-tuples get at + compute-slot-permutation + apply-slot-permutation ; : change-tuple ( tuple quot -- newtuple ) >r tuple>array r> call >tuple ; inline -: update-tuples ( predicate n permutation -- ) - [ permute-all-slots ] 2curry [ change-tuple ] curry - >r "predicate" word-prop instances dup r> map - become ; inline +: update-tuple ( tuple -- newtuple ) + [ permute-slots ] change-tuple ; -: update-tuples-after ( class superclass newslots -- ) - [ 2drop ] [ slot-permutation ] 3bi - [ update-tuples ] 3curry after-compilation ; +: update-tuples ( -- ) + outdated-tuples get + dup assoc-empty? [ drop ] [ + [ >r class r> key? ] curry instances + dup [ update-tuple ] map become + ] if ; + +[ update-tuples ] update-tuples-hook set-global + +: update-tuples-after ( class -- ) + outdated-tuples get [ all-slot-names ] cache drop ; + +: subclasses ( class -- classes ) + class-usages keys [ tuple-class? ] subset ; + +: each-subclass ( class quot -- ) + >r subclasses r> each ; inline + +: define-tuple-shape ( class -- ) + [ define-tuple-slots ] + [ define-tuple-layout ] + [ define-tuple-predicate ] + tri ; : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] - [ nip "slot-names" set-word-prop ] [ + [ nip "slot-names" set-word-prop ] + [ 2drop - class-usages keys [ tuple-class? ] subset [ - [ define-tuple-slots ] - [ define-tuple-layout ] - [ define-tuple-predicate ] - tri - ] each + [ define-tuple-shape ] each-subclass ] 3tri ; : redefine-tuple-class ( class superclass slots -- ) - [ update-tuples-after ] + [ + 2drop + [ update-tuples-after ] each-subclass + ] [ nip [ forget-removed-slots ] @@ -205,11 +221,6 @@ M: tuple clone M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; -: delegates ( obj -- seq ) - [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; - -: is? ( obj quot -- ? ) >r delegates r> contains? ; inline - M: tuple hashcode* [ dup tuple-size -rot 0 -rot [ @@ -217,21 +228,26 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -! Definition protocol M: tuple-class reset-class { "metaclass" "superclass" "slots" "layout" } reset-props ; M: object get-slots ( obj slots -- ... ) [ execute ] with each ; -M: object set-slots ( ... obj slots -- ) - get-slots ; - M: object construct-empty ( class -- tuple ) tuple-layout ; +M: object construct-boa ( ... class -- tuple ) + tuple-layout ; + +! Deprecated +M: object set-slots ( ... obj slots -- ) + get-slots ; + M: object construct ( ... slots class -- tuple ) construct-empty [ swap set-slots ] keep ; -M: object construct-boa ( ... class -- tuple ) - tuple-layout ; +: delegates ( obj -- seq ) + [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; + +: is? ( obj quot -- ? ) >r delegates r> contains? ; inline diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 9849ddca7d..f87c1ec985 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- ) dup [ drop crossref? ] assoc-contains? modify-code-heap ; -SYMBOL: post-compile-tasks - -: after-compilation ( quot -- ) - post-compile-tasks get push ; +SYMBOL: outdated-tuples +SYMBOL: update-tuples-hook : call-recompile-hook ( -- ) changed-words get keys compiled-usages recompile-hook get call ; -: call-post-compile-tasks ( -- ) - post-compile-tasks get [ call ] each ; +: call-update-tuples-hook ( -- ) + update-tuples-hook get call ; : finish-compilation-unit ( -- ) call-recompile-hook - call-post-compile-tasks + call-update-tuples-hook dup [ drop crossref? ] assoc-contains? modify-code-heap changed-definitions notify-definition-observers ; @@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks [ H{ } clone changed-words set H{ } clone forgotten-definitions set - V{ } clone post-compile-tasks set + H{ } clone outdated-tuples set new-definitions set old-definitions set [ finish-compilation-unit ] diff --git a/core/slots/slots.factor b/core/slots/slots.factor index eeb0926308..b674ec8c2a 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -79,3 +79,6 @@ C: slot-spec dup slot-spec-offset swap slot-spec-name define-slot-methods ] with each ; + +: slot-named ( name specs -- spec/f ) + [ slot-spec-name = ] with find nip ; From 75497d721219261a7b45a47f018d6314d2fe533a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 01:26:09 -0500 Subject: [PATCH 25/36] Add another unit test --- core/classes/tuple/tuple-tests.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 0fac0c3779..950650dbf0 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -410,6 +410,14 @@ test-a/b test-a/b +! Twice in the same compilation unit +[ + test1 tuple { "a" "x" "y" } define-tuple-class + test1 tuple { "a" "y" } define-tuple-class +] with-compilation-unit + +test-a/b + ! Redefinition problem TUPLE: redefinition-problem ; From 30a7238f71fa930b46fceea9024fc1e9cbceef2a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 02:30:06 -0500 Subject: [PATCH 26/36] Clean up serialization --- extra/serialize/serialize.factor | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index ac247057f4..7a2fbfae9e 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -90,13 +90,13 @@ M: float (serialize) ( obj -- ) M: complex (serialize) ( obj -- ) CHAR: c write1 - dup real-part (serialize) - imaginary-part (serialize) ; + [ real-part (serialize) ] + [ imaginary-part (serialize) ] bi ; M: ratio (serialize) ( obj -- ) CHAR: r write1 - dup numerator (serialize) - denominator (serialize) ; + [ numerator (serialize) ] + [ denominator (serialize) ] bi ; : serialize-seq ( obj code -- ) [ @@ -120,7 +120,8 @@ M: array (serialize) ( obj -- ) M: quotation (serialize) ( obj -- ) [ - CHAR: q write1 [ >array (serialize) ] [ add-object ] bi + CHAR: q write1 + [ >array (serialize) ] [ add-object ] bi ] serialize-shared ; M: hashtable (serialize) ( obj -- ) @@ -234,10 +235,12 @@ SYMBOL: deserialized ] if ; : deserialize-gensym ( -- word ) - gensym - dup intern-object - dup (deserialize) define - dup (deserialize) swap set-word-props ; + gensym { + [ intern-object ] + [ (deserialize) define ] + [ (deserialize) swap set-word-props ] + [ ] + } cleave ; : deserialize-wrapper ( -- wrapper ) (deserialize) ; From 8f0530daa6f8ce5a71dbea6f9edf081229301dc8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 03:40:27 -0500 Subject: [PATCH 27/36] More inheritance fixes --- core/classes/tuple/tuple-tests.factor | 44 ++++++++++++++++++++++++++- core/classes/tuple/tuple.factor | 15 +++++---- 2 files changed, 50 insertions(+), 9 deletions(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 950650dbf0..db0e25f091 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs namespaces quotations sequences.private classes continuations generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra -calendar prettyprint io.streams.string splitting ; +calendar prettyprint io.streams.string splitting inspector ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -418,6 +418,48 @@ test-a/b test-a/b +! Moving slots up and down +TUPLE: move-up-1 a b ; +TUPLE: move-up-2 < move-up-1 c ; + +T{ move-up-2 f "a" "b" "c" } "move-up" set + +: test-move-up + [ "a" ] [ "move-up" get a>> ] unit-test + [ "b" ] [ "move-up" get b>> ] unit-test + [ "c" ] [ "move-up" get c>> ] unit-test ; + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test + +! Constructors must be recompiled when changing superclass +TUPLE: constructor-update-1 xxx ; + +TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ; + +C: constructor-update-2 + +{ 3 1 } [ ] must-infer-as + +[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test + +{ 5 1 } [ ] must-infer-as + +[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 tuple-slots ] unit-test + ! Redefinition problem TUPLE: redefinition-problem ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 158ea9fc55..a3d0238d1c 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -184,15 +184,14 @@ PRIVATE> : redefine-tuple-class ( class superclass slots -- ) [ 2drop - [ update-tuples-after ] each-subclass - ] - [ - nip - [ forget-removed-slots ] - [ drop changed-word ] - [ drop redefined ] - 2tri + [ + [ update-tuples-after ] + [ changed-word ] + [ redefined ] + tri + ] each-subclass ] + [ nip forget-removed-slots ] [ define-new-tuple-class ] 3tri ; From 23bdf2faa7ac92bd433671539e5153166839122c Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 31 Mar 2008 08:57:16 -0500 Subject: [PATCH 28/36] add using --- extra/io/unix/sockets/sockets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index dea7dc17b5..c7931c6f0c 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces io.nonblocking parser threads unix sequences byte-arrays io.sockets io.binary io.unix.backend io.streams.duplex io.sockets.impl math.parser continuations libc -combinators ; +combinators io.backend ; IN: io.unix.sockets : pending-init-error ( port -- ) From b21d83b53130a87f6adc9498cf06c086081ce260 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 12:47:39 -0500 Subject: [PATCH 29/36] remove failing unit test for now --- extra/openssl/openssl-tests.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index c689f729d1..c85c0ee218 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -11,11 +11,12 @@ namespaces math math.parser openssl prettyprint sequences tools.test ; ] [ "Hello world from the openssl binding" >md5 ] unit-test -[ - B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 - 82 115 0 } -] -[ "Hello world from the openssl binding" >sha1 ] unit-test +! Not found on netbsd, windows -- why? +! [ + ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 + ! 82 115 0 } +! ] +! [ "Hello world from the openssl binding" >sha1 ] unit-test ! ========================================================= ! Initialize context From 0a63a8fb40dd290b36958bad7cda4b2751b961c6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 14:38:11 -0500 Subject: [PATCH 30/36] normalize-pathname in local sockets --- extra/io/unix/sockets/sockets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index bd7dfd9ce1..dea7dc17b5 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ; M: local sockaddr-type drop "sockaddr-un" c-type ; M: local make-sockaddr - local-path + local-path normalize-pathname dup length 1 + max-un-path > [ "Path too long" throw ] when "sockaddr-un" AF_UNIX over set-sockaddr-un-family From f49c72bb05fd5a2af16622f20b6771a857b10fac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 15:31:51 -0500 Subject: [PATCH 31/36] remove curry2 from mersenne.private... --- extra/random/mersenne-twister/mersenne-twister.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index ce1749ce62..8ddbdac6f4 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -9,9 +9,6 @@ IN: random.mersenne-twister r over r> [ curry ] 2bi@ ; inline - TUPLE: mersenne-twister seq i ; : mt-n 624 ; inline @@ -27,7 +24,7 @@ TUPLE: mersenne-twister seq i ; r> bitxor bitxor r> r> set-nth ; inline : calculate-y ( y1 y2 mt -- y ) - [ nth mt-hi ] [ nth mt-lo ] curry2 bi* bitor ; inline + tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline : (mt-generate) ( n mt-seq -- y to from-elt ) [ >r dup 1+ mt-wrap r> calculate-y ] From c2fdd797bcbff592ac1a65cba2044d7f8aef719f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 16:20:09 -0500 Subject: [PATCH 32/36] Try to fix inotify again --- extra/io/unix/linux/linux.factor | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 7580e7bf6b..3a8fad3d4d 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,8 +3,8 @@ USING: kernel io.backend io.monitors io.monitors.private io.files io.buffers io.nonblocking io.timeouts io.unix.backend io.unix.select io.unix.launcher unix.linux.inotify assocs -namespaces threads continuations init math -alien.c-types alien vocabs.loader ; +namespaces threads continuations init math alien.c-types alien +vocabs.loader accessors ; IN: io.unix.linux TUPLE: linux-io ; @@ -18,18 +18,16 @@ TUPLE: linux-monitor ; TUPLE: inotify watches ; -: watches ( -- assoc ) inotify get-global inotify-watches ; +: watches ( -- assoc ) inotify get-global watches>> ; : wd>monitor ( wd -- monitor ) watches at ; : ( -- port/f ) H{ } clone - inotify_init dup 0 < [ 2drop f ] [ - inotify - { set-inotify-watches set-delegate } inotify construct - ] if ; + inotify_init [ io-error ] [ inotify ] bi + { set-inotify-watches set-delegate } inotify construct ; -: inotify-fd inotify get-global port-handle ; +: inotify-fd inotify get-global handle>> ; : (add-watch) ( path mask -- wd ) inotify-fd -rot inotify_add_watch dup io-error ; @@ -80,10 +78,10 @@ M: linux-monitor dispose ( monitor -- ) parse-action swap alien>char-string ; : events-exhausted? ( i buffer -- ? ) - buffer-fill >= ; + fill>> >= ; : inotify-event@ ( i buffer -- alien ) - buffer-ptr ; + ptr>> ; : next-event ( i buffer -- i buffer ) 2dup inotify-event@ @@ -111,14 +109,17 @@ TUPLE: inotify-task ; f inotify-task ; : init-inotify ( mx -- ) - dup inotify set-global + + dup inotify set-global swap register-io-task ; M: inotify-task do-io-task ( task -- ) io-task-port read-notifications f ; M: linux-io init-io ( -- ) - dup mx set-global init-inotify ; + + [ mx set-global ] + [ [ init-inotify ] ignore-errors ] bi ; T{ linux-io } set-io-backend From 8742c3f2dcb95f5e6efcdf9ac94e52819096b1e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 31 Mar 2008 16:20:22 -0500 Subject: [PATCH 33/36] Oops --- extra/io/unix/linux/linux.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 3a8fad3d4d..2ae4065fb6 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -119,7 +119,7 @@ M: inotify-task do-io-task ( task -- ) M: linux-io init-io ( -- ) [ mx set-global ] - [ [ init-inotify ] ignore-errors ] bi ; + [ [ init-inotify ] curry ignore-errors ] bi ; T{ linux-io } set-io-backend From 13b31be060071a645bdef5ed61e258d6173e93a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 13:43:42 -0500 Subject: [PATCH 34/36] fix copy-tree --- core/io/files/files.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 458a9145a6..f397af606b 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -4,6 +4,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 accessors ; +USE: tools.walker IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -267,6 +268,7 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) + normalize-pathname over link-info type>> { { +symbolic-link+ [ copy-link ] } From b13ac1e17f323f826669f6758a90453940e4cbb5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 13:51:24 -0500 Subject: [PATCH 35/36] remove using --- core/io/files/files.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index f397af606b..099acb157e 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -4,7 +4,6 @@ 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 accessors ; -USE: tools.walker IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) From a8e223f47143bf193d5df8f7b3bfe2308c7cb574 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 31 Mar 2008 13:51:34 -0500 Subject: [PATCH 36/36] fix unix domain socket test --- extra/io/sockets/sockets.factor | 3 ++- extra/io/unix/sockets/sockets.factor | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 1dc7f4883d..e1cc36cd2e 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -6,7 +6,8 @@ IN: io.sockets TUPLE: local path ; -C: local +: ( path -- addrspec ) + normalize-pathname local construct-boa ; TUPLE: inet4 host port ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index c7931c6f0c..69ce6a3069 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces io.nonblocking parser threads unix sequences byte-arrays io.sockets io.binary io.unix.backend io.streams.duplex io.sockets.impl math.parser continuations libc -combinators io.backend ; +combinators io.backend io.files ; IN: io.unix.sockets : pending-init-error ( port -- ) @@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ; M: local sockaddr-type drop "sockaddr-un" c-type ; M: local make-sockaddr - local-path normalize-pathname + local-path cwd prepend-path dup length 1 + max-un-path > [ "Path too long" throw ] when "sockaddr-un" AF_UNIX over set-sockaddr-un-family