diff --git a/Makefile b/Makefile old mode 100644 new mode 100755 index 36538b041d..33d42217a2 --- a/Makefile +++ b/Makefile @@ -10,7 +10,6 @@ VERSION = 0.92 BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib CFLAGS = -Wall -Werror -FFI_TEST_CFLAGS = -fPIC ifdef DEBUG CFLAGS += -g -DFACTOR_DEBUG diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index 9cc05b4159..f9fdce806f 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ; ] when* ; : init-alarms ( -- ) - alarms global [ cancel-alarms ] change-at + alarms [ cancel-alarms ] change-global [ alarm-thread-loop t ] "Alarms" spawn-server alarm-thread set-global ; diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor old mode 100644 new mode 100755 index c555061e58..eac7655c38 --- a/basis/alien/libraries/libraries-docs.factor +++ b/basis/alien/libraries/libraries-docs.factor @@ -15,7 +15,7 @@ HELP: libraries { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ; HELP: library -{ $values { "name" "a string" } { "library" "a hashtable" } } +{ $values { "name" "a string" } { "library" assoc } } { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:" { $list { { $snippet "name" } " - the full path of the C library binary" } diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 6e82e16268..7940703140 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -23,7 +23,7 @@ IN: bootstrap.compiler "cpu." cpu name>> append require -enable-compiler +enable-optimizer ! Push all tuple layouts to tenured space to improve method caching gc diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 69d698f9b1..3e933e6643 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -7,7 +7,7 @@ compiler.units lexer init ; IN: cocoa : (remember-send) ( selector variable -- ) - global [ dupd ?set-at ] change-at ; + [ dupd ?set-at ] change-global ; SYMBOL: sent-messages diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 49511fe579..306ab515a8 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -4,16 +4,16 @@ compiler.units help.markup help.syntax io parser quotations sequences words ; IN: compiler -HELP: enable-compiler +HELP: enable-optimizer { $description "Enables the optimizing compiler." } ; -HELP: disable-compiler +HELP: disable-optimizer { $description "Disable the optimizing compiler." } ; ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically. This can be changed:" -{ $subsection disable-compiler } -{ $subsection enable-compiler } +{ $subsection disable-optimizer } +{ $subsection enable-optimizer } "Removing a word's optimized definition:" { $subsection decompile } "Compiling a single quotation:" diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index cc9899878a..e418f0ef60 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -192,10 +192,13 @@ M: optimizing-compiler recompile ( words -- alist ) compiled get >alist ] with-scope ; -: enable-compiler ( -- ) +: with-optimizer ( quot -- ) + [ optimizing-compiler compiler-impl ] dip with-variable ; inline + +: enable-optimizer ( -- ) optimizing-compiler compiler-impl set-global ; -: disable-compiler ( -- ) +: disable-optimizer ( -- ) f compiler-impl set-global ; : recompile-all ( -- ) diff --git a/basis/compiler/tests/call-effect.factor b/basis/compiler/tests/call-effect.factor index 407250a685..a9fd313d64 100644 --- a/basis/compiler/tests/call-effect.factor +++ b/basis/compiler/tests/call-effect.factor @@ -4,4 +4,11 @@ USING: tools.test combinators generic.single sequences kernel ; : execute-ic-test ( a b -- c ) execute( a -- c ) ; ! VM type check error -[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with \ No newline at end of file +[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with + +: call-test ( q -- ) call( -- ) ; + +[ ] [ [ ] call-test ] unit-test +[ ] [ f [ drop ] curry call-test ] unit-test +[ ] [ [ ] [ ] compose call-test ] unit-test +[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with \ No newline at end of file diff --git a/basis/compiler/tests/generic.factor b/basis/compiler/tests/generic.factor new file mode 100644 index 0000000000..6b0ef2d439 --- /dev/null +++ b/basis/compiler/tests/generic.factor @@ -0,0 +1,11 @@ +IN: compiler.tests.generic +USING: tools.test math kernel compiler.units definitions ; + +GENERIC: bad ( -- ) +M: integer bad ; +M: object bad ; + +[ 0 bad ] must-fail +[ "" bad ] must-fail + +[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/redefine14.factor b/basis/compiler/tests/redefine14.factor index 807f3ed2c7..a72db4833c 100644 --- a/basis/compiler/tests/redefine14.factor +++ b/basis/compiler/tests/redefine14.factor @@ -1,8 +1,8 @@ USING: compiler.units definitions tools.test sequences ; IN: compiler.tests.redefine14 -! TUPLE: bad ; -! -! M: bad length 1 2 3 ; -! -! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test +TUPLE: bad ; + +M: bad length 1 2 3 ; + +[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tests/redefine17.factor b/basis/compiler/tests/redefine17.factor new file mode 100644 index 0000000000..4ed3e36f4d --- /dev/null +++ b/basis/compiler/tests/redefine17.factor @@ -0,0 +1,49 @@ +IN: compiler.tests.redefine17 +USING: tools.test classes.mixin compiler.units arrays kernel.private +strings sequences vocabs definitions kernel ; + +<< "compiler.tests.redefine17" words forget-all >> + +GENERIC: bong ( a -- b ) + +M: array bong ; + +M: string bong length ; + +MIXIN: mixin + +INSTANCE: array mixin + +: blah ( a -- b ) { mixin } declare bong ; + +[ { } ] [ { } blah ] unit-test + +[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test + +[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test + +[ 0 ] [ "" blah ] unit-test + +MIXIN: mixin1 + +INSTANCE: string mixin1 + +MIXIN: mixin2 + +GENERIC: billy ( a -- b ) + +M: mixin2 billy ; + +M: array billy drop "BILLY" ; + +INSTANCE: string mixin2 + +: bully ( a -- b ) { mixin1 } declare billy ; + +[ "" ] [ "" bully ] unit-test + +[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test + +[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test + +[ "BILLY" ] [ { } bully ] unit-test diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 2776ed914f..4d4b22218d 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -59,21 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval } : ( -- info ) \ value-info new ; -: read-only-slots ( values class -- slots ) - all-slots - [ read-only>> [ drop f ] unless ] 2map - f prefix ; - DEFER: +: tuple-slot-infos ( tuple -- slots ) + [ tuple-slots ] [ class all-slots ] bi + [ read-only>> [ ] [ drop f ] if ] 2map + f prefix ; + : init-literal-info ( info -- info ) dup literal>> class >>class dup literal>> dup real? [ [a,a] >>interval ] [ [ [-inf,inf] >>interval ] dip - dup tuple? [ - [ tuple-slots [ ] map ] [ class ] bi - read-only-slots >>slots - ] [ drop ] if + dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if ] if ; inline : init-value-info ( info -- info ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index ed8d2983b5..eba41dbfdf 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays.double system sorting math.libm -math.intervals ; +math.intervals quotations ; IN: compiler.tree.propagation.tests [ V{ } ] [ [ ] final-classes ] unit-test @@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test [ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test + +! Mutable tuples with circularity should not cause problems +TUPLE: circle me ; + +[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 89c2bada8b..86114772f7 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -30,8 +30,13 @@ UNION: fixed-length-sequence array byte-array string ; [ [ literal>> ] map ] dip prefix >tuple ; +: read-only-slots ( values class -- slots ) + all-slots + [ read-only>> [ value-info ] [ drop f ] if ] 2map + f prefix ; + : (propagate-tuple-constructor) ( values class -- info ) - [ [ value-info ] map ] dip [ read-only-slots ] keep + [ read-only-slots ] keep over rest-slice [ dup [ literal?>> ] when ] all? [ [ rest-slice ] dip fold- ] [ diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 46f6639ab8..1956cd9c20 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks \ event-stream-counter counter ; [ - event-stream-callbacks global - [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at + event-stream-callbacks + [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global ] "core-foundation" add-init-hook : add-event-source-callback ( quot -- id ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index b280afc01e..10cd9c8657 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -309,7 +309,7 @@ FUNCTION: bool check_sse2 ( ) ; check_sse2 ; "-no-sse2" (command-line) member? [ - optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable + [ { check_sse2 } compile ] with-optimizer "Checking if your CPU supports SSE2..." print flush sse2? [ diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index f6a40d8dc8..9f9aca8702 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,6 +1,6 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string -accessors eval multiline generic.standard delegate.protocols +accessors eval multiline generic.single delegate.protocols delegate.private assocs see ; IN: delegate.tests diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor index f485f1bec1..0776f8f158 100644 --- a/basis/documents/elements/elements.factor +++ b/basis/documents/elements/elements.factor @@ -79,6 +79,13 @@ M: one-word-elt next-elt drop [ f next-word ] modify-col ; +SINGLETON: word-start-elt + +M: word-start-elt prev-elt + drop one-word-elt prev-elt ; + +M: word-start-elt next-elt 2drop ; + SINGLETON: word-elt M: word-elt prev-elt diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 0d7f7851e2..e00f8e2263 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -1,6 +1,7 @@ USING: http help.markup help.syntax io.pathnames io.streams.string io.encodings.8-bit io.encodings.binary kernel strings urls -urls.encoding byte-arrays strings assocs sequences destructors ; +urls.encoding byte-arrays strings assocs sequences destructors +http.client.post-data.private ; IN: http.client HELP: download-failed @@ -71,7 +72,7 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client" { $subsection with-http-get } { $subsection with-http-request } ; -ARTICLE: "http.client.post-data" "HTTP client submission data" +ARTICLE: "http.client.post-data" "HTTP client post data" "HTTP POST and PUT request words take a post data parameter, which can be one of the following:" { $list { "a " { $link byte-array } ": the data is sent the server without further encoding" } @@ -85,7 +86,9 @@ ARTICLE: "http.client.post-data" "HTTP client submission data" { $code "\"my-large-post-request.txt\" ascii " "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal" -} ; +} +"An internal word used to convert objects to " { $link post-data } " instances:" +{ $subsection >post-data } ; ARTICLE: "http.client.post" "POST requests with the HTTP client" "Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:" diff --git a/basis/http/client/post-data/post-data-docs.factor b/basis/http/client/post-data/post-data-docs.factor new file mode 100644 index 0000000000..24325e9ebd --- /dev/null +++ b/basis/http/client/post-data/post-data-docs.factor @@ -0,0 +1,6 @@ +IN: http.client.post-data +USING: http http.client.post-data.private help.markup help.syntax kernel ; + +HELP: >post-data +{ $values { "object" object } { "post-data" { $maybe post-data } } } +{ $description "Converts an object into a " { $link post-data } " tuple instance." } ; diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor old mode 100644 new mode 100755 index 6148394c57..8fcf12aae9 --- a/basis/io/styles/styles-docs.factor +++ b/basis/io/styles/styles-docs.factor @@ -1,17 +1,17 @@ USING: help.markup help.syntax io.streams.plain io strings -hashtables kernel quotations colors ; +hashtables kernel quotations colors assocs ; IN: io.styles HELP: stream-format -{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } } +{ $values { "str" string } { "style" assoc } { "stream" "an output stream" } } { $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." $nl -"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." } +"The " { $snippet "style" } " assoc holds character style information. See " { $link "character-styles" } "." } { $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." } $io-error ; HELP: make-block-stream -{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } +{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } } { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." $nl "Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output." @@ -21,7 +21,7 @@ $nl $io-error ; HELP: stream-write-table -{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } } +{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" assoc } { "stream" "an output stream" } } { $contract "Prints a table of cells produced by " { $link with-cell } "." $nl "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } @@ -29,13 +29,13 @@ $nl $io-error ; HELP: make-cell-stream -{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } } +{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" object } } { $contract "Creates an output stream which writes to a table cell object." } { $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." } $io-error ; HELP: make-span-stream -{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } +{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } } { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." $nl "Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." } @@ -43,19 +43,19 @@ $nl $io-error ; HELP: format -{ $values { "str" string } { "style" "a hashtable" } } +{ $values { "str" string } { "style" assoc } } { $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $notes "Details are in the documentation for " { $link stream-format } "." } $io-error ; HELP: with-nesting -{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $values { "style" assoc } { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." } { $notes "Details are in the documentation for " { $link make-block-stream } "." } $io-error ; HELP: tabular-output -{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $values { "style" assoc } { "quot" quotation } } { $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "." $nl "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } @@ -85,7 +85,7 @@ HELP: write-cell $io-error ; HELP: with-style -{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $values { "style" assoc } { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." } { $notes "Details are in the documentation for " { $link make-span-stream } "." } $io-error ; diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor old mode 100644 new mode 100755 index acd2c3383f..6a4672bea0 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -49,6 +49,7 @@ $nl { $subsection POSTPONE: MACRO: } "A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion." { $subsection define-transform } -"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ; +"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." +{ $see-also "generalizations" "fry" } ; ABOUT: "macros" diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 683fa328d8..cae1e05dc8 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -199,10 +199,10 @@ IN: peg.tests USE: compiler -[ ] [ disable-compiler ] unit-test +[ ] [ disable-optimizer ] unit-test [ ] [ "" epsilon parse drop ] unit-test -[ ] [ enable-compiler ] unit-test +[ ] [ enable-optimizer ] unit-test [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test diff --git a/basis/refs/refs-docs.factor b/basis/refs/refs-docs.factor old mode 100644 new mode 100755 index 9c10641c4c..9971a1d4fa --- a/basis/refs/refs-docs.factor +++ b/basis/refs/refs-docs.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: boxes help.markup help.syntax kernel math namespaces ; +USING: boxes help.markup help.syntax kernel math namespaces assocs ; IN: refs ARTICLE: "refs" "References" -"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "." -{ $subsection get-ref } -{ $subsection set-ref } -{ $subsection set-ref* } -{ $subsection delete-ref } +"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing a protocol." +{ $subsection "refs-protocol" } +{ $subsection "refs-impls" } +{ $subsection "refs-utils" } +"References are used by the " { $link "ui-inspector" } "." ; + +ABOUT: "refs" + +ARTICLE: "refs-impls" "Reference implementations" "References to objects:" { $subsection obj-ref } { $subsection } @@ -27,20 +31,24 @@ ARTICLE: "refs" "References" { $subsection slot-ref } { $subsection } "Using boxes as references:" -{ $subsection "box-refs" } -"References are used by the UI inspector." ; +{ $subsection "box-refs" } ; -ABOUT: "refs" +ARTICLE: "refs-utils" "Reference utilities" +{ $subsection ref-on } +{ $subsection ref-off } +{ $subsection ref-inc } +{ $subsection ref-dec } +{ $subsection set-ref* } ; -ARTICLE: "refs-protocol" "Reference Protocol" +ARTICLE: "refs-protocol" "Reference protocol" "To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:" { $subsection get-ref } { $subsection set-ref } "References may also implement:" { $subsection delete-ref } ; -ARTICLE: "box-refs" "Using Boxes as References" -"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ; +ARTICLE: "box-refs" "Boxes as references" +{ $link "boxes" } " are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ; HELP: ref { $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ; @@ -89,14 +97,14 @@ HELP: key-ref { $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link } "." } ; HELP: -{ $values { "assoc" "an assoc" } { "key" object } { "key-ref" key-ref } } +{ $values { "assoc" assoc } { "key" object } { "key-ref" key-ref } } { $description "Creates a reference to a key stored in an assoc." } ; HELP: value-ref { $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link } "." } ; HELP: -{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } } +{ $values { "assoc" assoc } { "key" object } { "value-ref" value-ref } } { $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ; { get-ref set-ref delete-ref set-ref* } related-words diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index 4adc5952fd..b3b678d93d 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -19,7 +19,7 @@ IN: stack-checker.call-effect TUPLE: inline-cache value ; : cache-hit? ( word/quot ic -- ? ) - [ value>> ] [ value>> eq? ] bi and ; inline + [ value>> eq? ] [ value>> ] bi and ; inline SINGLETON: +unknown+ diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor old mode 100644 new mode 100755 index 7a87ab988d..6a67b815cd --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -84,8 +84,11 @@ HELP: inconsistent-recursive-call-error } ; ARTICLE: "inference-errors" "Stack checker errors" -"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "." -$nl +"These " { $link "inference" } " failure conditions are reported in one of two ways:" +{ $list + { { $link "tools.inference" } " throws them as errors" } + { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } } +} "Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):" { $subsection literal-expected } "Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index ad46a0d227..8113a662d6 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -19,7 +19,6 @@ IN: stack-checker.transforms rstate recursive-state [ word stack quot call-transformer ] with-variable [ - word inlined-dependency depends-on values [ length meta-d shorten-by ] [ #drop, ] bi rstate infer-quot ] [ word infer-word ] if* ; diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index eb780e40cc..f997a6eb3a 100644 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -16,4 +16,5 @@ IN: tools.deploy.test : run-temp-image ( -- ) vm "-i=" "test.image" temp-file append - 2array try-process ; \ No newline at end of file + 2array + swap >>command +closed+ >>stdin try-process ; \ No newline at end of file diff --git a/basis/tools/disassembler/disassembler-tests.factor b/basis/tools/disassembler/disassembler-tests.factor index 49cfb054a1..89ca265bf6 100644 --- a/basis/tools/disassembler/disassembler-tests.factor +++ b/basis/tools/disassembler/disassembler-tests.factor @@ -1,6 +1,4 @@ IN: tools.disassembler.tests -USING: math classes.tuple prettyprint.custom -tools.disassembler tools.test strings ; +USING: kernel fry vocabs tools.disassembler tools.test sequences ; -[ ] [ \ + disassemble ] unit-test -[ ] [ M\ string pprint* disassemble ] unit-test +"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each \ No newline at end of file diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 51e399c1c3..cd9dd9cf4b 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -3,7 +3,7 @@ USING: tools.disassembler namespaces combinators alien alien.syntax alien.c-types lexer parser kernel sequences layouts math math.order alien.libraries -math.parser system make fry arrays ; +math.parser system make fry arrays libc destructors ; IN: tools.disassembler.udis << @@ -47,11 +47,14 @@ FUNCTION: uint ud_insn_len ( ud* u ) ; FUNCTION: char* ud_lookup_mnemonic ( int c ) ; : ( -- ud ) - "ud" + "ud" malloc-object &free dup ud_init dup cell-bits ud_set_mode dup UD_SYN_INTEL ud_set_syntax ; +: with-ud ( quot: ( ud -- ) -- ) + [ [ ] dip call ] with-destructors ; inline + SINGLETON: udis-disassembler : buf/len ( from to -- buf len ) [ drop ] [ swap - ] 2bi ; @@ -82,10 +85,12 @@ SINGLETON: udis-disassembler ] { } make ; M: udis-disassembler disassemble* ( from to -- buffer ) - [ ] 2dip { + '[ + _ _ [ drop ud_set_pc ] [ buf/len ud_set_input_buffer ] [ 2drop (disassemble) format-disassembly ] - } 3cleave ; + 3tri + ] with-ud ; udis-disassembler disassembler-backend set-global diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index ba99a41eba..4b9a72a443 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -74,8 +74,6 @@ SYMBOL: failures SYMBOL: changed-vocabs -[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook - : changed-vocab ( vocab -- ) dup vocab changed-vocabs get and [ dup changed-vocabs get set-at ] [ drop ] if ; @@ -287,3 +285,12 @@ MEMO: all-authors ( -- seq ) \ all-vocabs-seq reset-memoized \ all-authors reset-memoized \ all-tags reset-memoized ; + +SINGLETON: cache-observer + +M: cache-observer vocabs-changed drop reset-cache ; + +[ + f changed-vocabs set-global + cache-observer add-vocab-observer +] "tools.vocabs" add-init-hook \ No newline at end of file diff --git a/basis/tuple-arrays/summary.txt b/basis/tuple-arrays/summary.txt new file mode 100755 index 0000000000..6f5c8b7244 --- /dev/null +++ b/basis/tuple-arrays/summary.txt @@ -0,0 +1 @@ +Efficient arrays of tuples with value semantics for elements diff --git a/basis/tuple-arrays/tags.txt b/basis/tuple-arrays/tags.txt new file mode 100755 index 0000000000..42d711b32b --- /dev/null +++ b/basis/tuple-arrays/tags.txt @@ -0,0 +1 @@ +collections diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 6cfb83a49a..80829d7b66 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -53,8 +53,8 @@ CONSTANT: min-thumb-dim 30 [ slider-max* 1 max ] bi / ; -: slider>screen ( m slider -- n ) slider-scale * elevator-padding + ; -: screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ; +: slider>screen ( m slider -- n ) slider-scale * ; +: screen>slider ( m slider -- n ) slider-scale / ; M: slider model-changed nip elevator>> relayout-1 ; @@ -133,7 +133,7 @@ elevator H{ swap >>orientation ; : thumb-loc ( slider -- loc ) - [ slider-value ] keep slider>screen ; + [ slider-value ] keep slider>screen elevator-padding + ; : layout-thumb-loc ( thumb slider -- ) [ thumb-loc ] [ orientation>> ] bi n*v diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index d390b1e49b..ba3b5a2f78 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -46,14 +46,16 @@ mouse-index { takes-focus? initial: t } focused? ; -: ( rows renderer -- table ) - table new-line-gadget +: new-table ( rows renderer class -- table ) + new-line-gadget swap >>renderer swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; + transparent >>column-line-color ; inline + +:
( rows renderer -- table ) table new-table ; string os ( keysym -- string ) M: macosx keysym>string >upper ; -M: object keysym>string ; +M: object keysym>string dup length 1 = [ >lower ] when ; M: key-down gesture>string [ mods>> ] [ sym>> ] bi { { [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] } { [ dup " " = ] [ drop "SPACE" ] } - [ keysym>string ] + [ ] } cond - [ modifiers>string ] dip append ; + [ modifiers>string ] [ keysym>string ] bi* append ; M: button-up gesture>string [ diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index a493d5d7d2..1b8af1dd03 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -25,7 +25,10 @@ M: browser-gadget set-history-value : show-help ( link browser-gadget -- ) [ >link ] dip - [ [ add-recent ] [ history>> add-history ] bi* ] + [ + 2dup model>> value>> = + [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if + ] [ model>> set-model ] 2bi ; diff --git a/basis/ui/tools/common/common.factor b/basis/ui/tools/common/common.factor index e581e72e24..95af20ec72 100644 --- a/basis/ui/tools/common/common.factor +++ b/basis/ui/tools/common/common.factor @@ -7,7 +7,7 @@ IN: ui.tools.common SYMBOL: tool-dims -tool-dims global [ H{ } clone or ] change-at +tool-dims [ H{ } clone ] initialize TUPLE: tool < track ; diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 17216bd656..fdba400c3d 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -39,7 +39,7 @@ M: history-completion completion-quot drop '[ drop _ history-list ] ; GENERIC: completion-element ( completion-mode -- element ) -M: object completion-element drop one-word-elt ; +M: object completion-element drop word-start-elt ; M: history-completion completion-element drop one-line-elt ; GENERIC: completion-banner ( completion-mode -- string ) @@ -72,13 +72,13 @@ M: vocab-completion row-color drop vocab? COLOR: black COLOR: dark-gray ? ; : complete-IN:/USE:? ( tokens -- ? ) - 2 short tail* { "IN:" "USE:" } intersects? ; + 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ; : chop-; ( seq -- seq' ) { ";" } split1-last [ ] [ ] ?if ; : complete-USING:? ( tokens -- ? ) - chop-; { "USING:" } intersects? ; + chop-; 1 short head* { "USING:" } intersects? ; : complete-CHAR:? ( tokens -- ? ) 2 short tail* "CHAR:" swap member? ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 8be486cb1a..09403cb2d2 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -28,7 +28,7 @@ SYMBOL: windows [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ; : unregister-window ( handle -- ) - windows global [ [ first = not ] with filter ] change-at ; + windows [ [ first = not ] with filter ] change-global ; : raised-window ( world -- ) windows get-global diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index 0f95c6d683..74238abed2 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -842,7 +842,7 @@ SYMBOLS: [ define-constants ] "windows.dinput.constants" add-init-hook : uninitialize ( variable quot -- ) - [ global ] dip '[ _ when* f ] change-at ; inline + '[ _ when* f ] change-global ; inline : free-dinput-constants ( -- ) { diff --git a/build-support/factor.sh b/build-support/factor.sh index 3ece72306a..ba5815cfc1 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -205,7 +205,7 @@ find_architecture() { write_test_program() { echo "#include " > $C_WORD.c - echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c } c_find_word_size() { diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor old mode 100644 new mode 100755 index cbef25ac38..8b301affbd --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -290,7 +290,6 @@ $nl "The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:" { $subsection call-effect } { $subsection execute-effect } -{ $subsection "call-unsafe" } "The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "." { $subsection "call-unsafe" } { $see-also "effects" "inference" } ; @@ -306,6 +305,7 @@ ARTICLE: "combinators" "Combinators" { $subsection "combinators.smart" } "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." { $subsection "combinators-quot" } +{ $subsection "generalizations" } { $see-also "quotations" } ; ABOUT: "combinators" diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor old mode 100644 new mode 100755 diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index da2dce128f..8dce12f411 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -19,7 +19,7 @@ IN: compiler.units.tests ] unit-test [ "A" "B" ] [ - disable-compiler + disable-optimizer gensym "a" set gensym "b" set @@ -33,7 +33,7 @@ IN: compiler.units.tests ] with-compilation-unit "b" get execute - enable-compiler + enable-optimizer ] unit-test ! Check that we notify observers diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index c4a137b2ba..f1f9131f08 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -43,6 +43,9 @@ HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler M: f recompile [ dup def>> ] { } map>assoc ; +: without-optimizer ( quot -- ) + [ f compiler-impl ] dip with-variable ; inline + ! Trivial compiler. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. SINGLETON: dummy-compiler @@ -58,6 +61,10 @@ GENERIC: definitions-changed ( assoc obj -- ) [ V{ } clone definition-observers set-global ] "compiler.units" add-init-hook +! This goes here because vocabs cannot depend on init +[ V{ } clone vocab-observers set-global ] +"vocabs" add-init-hook + : add-definition-observer ( obj -- ) definition-observers get push ; diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor old mode 100644 new mode 100755 index 5a19cce351..0619e798dc --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -116,7 +116,7 @@ HELP: ?set-at { $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ; HELP: >hashtable -{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } } +{ $values { "assoc" assoc } { "hashtable" hashtable } } { $description "Constructs a hashtable from any assoc." } ; HELP: rehash diff --git a/core/init/init.factor b/core/init/init.factor index 5d8e88b85f..0140fcc0e8 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations continuations.private kernel -kernel.private sequences assocs namespaces namespaces.private ; +kernel.private sequences assocs namespaces namespaces.private +continuations continuations.private ; IN: init SYMBOL: init-hooks diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 8f0fb9e97a..f57dafbdc6 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,7 @@ USING: arrays debugger.threads destructors io io.directories io.encodings.8-bit io.encodings.ascii io.encodings.binary io.files io.files.private io.files.temp io.files.unique kernel -make math sequences system threads tools.test generic.standard ; +make math sequences system threads tools.test generic.single ; IN: io.files.tests [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor old mode 100644 new mode 100755 index 74d7c58963..cd66e781d2 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private sequences words namespaces.private quotations vectors -math.parser math words.symbol ; +math.parser math words.symbol assocs ; IN: namespaces ARTICLE: "namespaces-combinators" "Namespace combinators" @@ -14,7 +14,8 @@ ARTICLE: "namespaces-change" "Changing variable values" { $subsection off } { $subsection inc } { $subsection dec } -{ $subsection change } ; +{ $subsection change } +{ $subsection change-global } ; ARTICLE: "namespaces-global" "Global variables" { $subsection namespace } @@ -73,6 +74,11 @@ HELP: change { $description "Applies the quotation to the old value of the variable, and assigns the resulting value to the variable." } { $side-effects "variable" } ; +HELP: change-global +{ $values { "variable" "a variable, by convention a symbol" } { "quot" { $quotation "( old -- new )" } } } +{ $description "Applies the quotation to the old value of the global variable, and assigns the resulting value to the global variable." } +{ $side-effects "variable" } ; + HELP: +@ { $values { "n" "a number" } { "variable" "a variable, by convention a symbol" } } { $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." } @@ -113,19 +119,19 @@ HELP: with-variable } ; HELP: make-assoc -{ $values { "quot" quotation } { "exemplar" "an assoc" } { "hash" "a new hashtable" } } +{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } } { $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ; HELP: bind -{ $values { "ns" "a hashtable" } { "quot" quotation } } +{ $values { "ns" assoc } { "quot" quotation } } { $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ; HELP: namespace -{ $values { "namespace" "an assoc" } } +{ $values { "namespace" assoc } } { $description "Outputs the current namespace. Calls to " { $link set } " modify this namespace." } ; HELP: global -{ $values { "g" "an assoc" } } +{ $values { "g" assoc } } { $description "Outputs the global namespace. The global namespace is always checked last when looking up variable values." } ; HELP: get-global @@ -150,7 +156,7 @@ HELP: set-namestack { $description "Replaces the name stack with a copy of the given vector." } ; HELP: >n -{ $values { "namespace" "an assoc" } } +{ $values { "namespace" assoc } } { $description "Pushes a namespace on the name stack." } ; HELP: ndrop diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index b0e764c94d..310816cbf7 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -24,12 +24,13 @@ PRIVATE> : get-global ( variable -- value ) global at ; : set-global ( value variable -- ) global set-at ; : change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline +: change-global ( variable quot -- ) [ global ] dip change-at ; inline : +@ ( n variable -- ) [ 0 or + ] change ; : inc ( variable -- ) 1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline : bind ( ns quot -- ) swap >n call ndrop ; inline -: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ; +: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ; : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline : with-scope ( quot -- ) 5 swap bind ; inline : with-variable ( value key quot -- ) [ associate ] dip bind ; inline -: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline \ No newline at end of file +: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline \ No newline at end of file diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index a122aa1240..3670b10d3c 100755 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -1,4 +1,4 @@ -USING: kernel help.markup help.syntax sequences quotations ; +USING: kernel help.markup help.syntax sequences quotations assocs ; IN: sets ARTICLE: "sets" "Set-theoretic operations on sequences" @@ -42,7 +42,7 @@ HELP: adjoin { $side-effects "seq" } ; HELP: conjoin -{ $values { "elt" object } { "assoc" "an assoc" } } +{ $values { "elt" object } { "assoc" assoc } } { $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." } { $examples { $example @@ -54,7 +54,7 @@ HELP: conjoin { $side-effects "assoc" } ; HELP: unique -{ $values { "seq" "a sequence" } { "assoc" "an assoc" } } +{ $values { "seq" "a sequence" } { "assoc" assoc } } { $description "Outputs a new assoc where the keys and values are equal." } { $examples { $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" } diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 7ac8446842..1365e81524 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -1,5 +1,5 @@ IN: slots.tests -USING: math accessors slots strings generic.standard kernel +USING: math accessors slots strings generic.single kernel tools.test generic words parser eval math.functions ; TUPLE: r/w-test foo ; diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 5b71b13552..22bf7bb821 100644 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -58,7 +58,7 @@ unit-test [ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test ! Random tester found this -[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with +[ 2 -7 resize-string ] [ { "kernel-error" 3 11 -7 } = ] must-fail-with ! Make sure 24-bit strings work "hello world" "s" set diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 2b978e8666..6c12b7b325 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -65,8 +65,22 @@ M: object vocab-main vocab vocab-main ; M: f vocab-main ; +SYMBOL: vocab-observers + +GENERIC: vocabs-changed ( obj -- ) + +: add-vocab-observer ( obj -- ) + vocab-observers get push ; + +: remove-vocab-observer ( obj -- ) + vocab-observers get delq ; + +: notify-vocab-observers ( -- ) + vocab-observers get [ vocabs-changed ] each ; + : create-vocab ( name -- vocab ) - dictionary get [ ] cache ; + dictionary get [ ] cache + notify-vocab-observers ; ERROR: no-vocab name ; @@ -99,7 +113,8 @@ M: string >vocab-link dup vocab [ ] [ ] ?if ; : forget-vocab ( vocab -- ) dup words forget-all - vocab-name dictionary get delete-at ; + vocab-name dictionary get delete-at + notify-vocab-observers ; M: vocab-spec forget* forget-vocab ; diff --git a/extra/bson/bson.factor b/extra/bson/bson.factor new file mode 100644 index 0000000000..a97b5029b0 --- /dev/null +++ b/extra/bson/bson.factor @@ -0,0 +1,6 @@ +USING: vocabs.loader ; + +IN: bson + +"bson.reader" require +"bson.writer" require diff --git a/extra/bson/constants/constants.factor b/extra/bson/constants/constants.factor new file mode 100644 index 0000000000..5148413b61 --- /dev/null +++ b/extra/bson/constants/constants.factor @@ -0,0 +1,49 @@ +USING: accessors constructors kernel strings uuid ; + +IN: bson.constants + +: ( -- objid ) + uuid1 ; inline + +TUPLE: oid { a initial: 0 } { b initial: 0 } ; + +TUPLE: objref ns objid ; + +CONSTRUCTOR: objref ( ns objid -- objref ) ; + +TUPLE: mdbregexp { regexp string } { options string } ; + +: ( string -- mdbregexp ) + [ mdbregexp new ] dip >>regexp ; + + +CONSTANT: MDB_OID_FIELD "_id" +CONSTANT: MDB_META_FIELD "_mfd" + +CONSTANT: T_EOO 0 +CONSTANT: T_Double 1 +CONSTANT: T_Integer 16 +CONSTANT: T_Boolean 8 +CONSTANT: T_String 2 +CONSTANT: T_Object 3 +CONSTANT: T_Array 4 +CONSTANT: T_Binary 5 +CONSTANT: T_Undefined 6 +CONSTANT: T_OID 7 +CONSTANT: T_Date 9 +CONSTANT: T_NULL 10 +CONSTANT: T_Regexp 11 +CONSTANT: T_DBRef 12 +CONSTANT: T_Code 13 +CONSTANT: T_ScopedCode 17 +CONSTANT: T_Symbol 14 +CONSTANT: T_JSTypeMax 16 +CONSTANT: T_MaxKey 127 + +CONSTANT: T_Binary_Function 1 +CONSTANT: T_Binary_Bytes 2 +CONSTANT: T_Binary_UUID 3 +CONSTANT: T_Binary_MD5 5 +CONSTANT: T_Binary_Custom 128 + + diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor new file mode 100644 index 0000000000..96cde41c2b --- /dev/null +++ b/extra/bson/reader/reader.factor @@ -0,0 +1,200 @@ +USING: accessors assocs bson.constants byte-arrays byte-vectors fry io +io.binary io.encodings.string io.encodings.utf8 kernel math namespaces +sequences serialize arrays calendar io.encodings ; + +IN: bson.reader + + ( exemplar -- state ) + [ state new ] dip + [ clone >>exemplar ] keep + clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi + V{ } clone [ T_Object "" element boa swap push ] keep >>element ; + +PREDICATE: bson-eoo < integer T_EOO = ; +PREDICATE: bson-not-eoo < integer T_EOO > ; + +PREDICATE: bson-double < integer T_Double = ; +PREDICATE: bson-integer < integer T_Integer = ; +PREDICATE: bson-string < integer T_String = ; +PREDICATE: bson-object < integer T_Object = ; +PREDICATE: bson-array < integer T_Array = ; +PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-regexp < integer T_Regexp = ; +PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; +PREDICATE: bson-binary-function < integer T_Binary_Function = ; +PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ; +PREDICATE: bson-binary-custom < integer T_Binary_Custom = ; +PREDICATE: bson-oid < integer T_OID = ; +PREDICATE: bson-boolean < integer T_Boolean = ; +PREDICATE: bson-date < integer T_Date = ; +PREDICATE: bson-null < integer T_NULL = ; +PREDICATE: bson-ref < integer T_DBRef = ; + +GENERIC: element-read ( type -- cont? ) +GENERIC: element-data-read ( type -- object ) +GENERIC: element-binary-read ( length type -- object ) + +: byte-array>number ( seq -- number ) + byte-array>bignum >integer ; inline + +: get-state ( -- state ) + state get ; inline + +: count-bytes ( count -- ) + [ get-state ] dip '[ _ + ] change-read drop ; inline + +: read-int32 ( -- int32 ) + 4 [ read byte-array>number ] [ count-bytes ] bi ; inline + +: read-longlong ( -- longlong ) + 8 [ read byte-array>number ] [ count-bytes ] bi ; inline + +: read-double ( -- double ) + 8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline + +: read-byte-raw ( -- byte-raw ) + 1 [ read ] [ count-bytes ] bi ; inline + +: read-byte ( -- byte ) + read-byte-raw first ; inline + +: read-cstring ( -- string ) + input-stream get utf8 + "\0" swap stream-read-until drop ; inline + +: read-sized-string ( length -- string ) + drop read-cstring ; inline + +: read-element-type ( -- type ) + read-byte ; inline + +: push-element ( type name -- element ) + element boa + [ get-state element>> push ] keep ; inline + +: pop-element ( -- element ) + get-state element>> pop ; inline + +: peek-scope ( -- ht ) + get-state scope>> peek ; inline + +: read-elements ( -- ) + read-element-type + element-read + [ read-elements ] when ; inline recursive + +GENERIC: fix-result ( assoc type -- result ) + +M: bson-object fix-result ( assoc type -- result ) + drop ; + +M: bson-array fix-result ( assoc type -- result ) + drop + values ; + +GENERIC: end-element ( type -- ) + +M: bson-object end-element ( type -- ) + drop ; + +M: bson-array end-element ( type -- ) + drop ; + +M: object end-element ( type -- ) + drop + pop-element drop ; + +M: bson-eoo element-read ( type -- cont? ) + drop + get-state scope>> [ pop ] keep swap ! vec assoc + pop-element [ type>> ] keep ! vec assoc element + [ fix-result ] dip + rot length 0 > ! assoc element + [ name>> peek-scope set-at t ] + [ drop [ get-state ] dip >>result drop f ] if ; + +M: bson-not-eoo element-read ( type -- cont? ) + [ peek-scope ] dip ! scope type + '[ _ read-cstring push-element [ name>> ] [ type>> ] bi + [ element-data-read ] keep + end-element + swap + ] dip set-at t ; + +: [scope-changer] ( state -- state quot ) + dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline + +: (object-data-read) ( type -- object ) + drop + read-int32 drop + get-state + [scope-changer] change-scope + scope>> peek ; inline + +M: bson-object element-data-read ( type -- object ) + (object-data-read) ; + +M: bson-array element-data-read ( type -- object ) + (object-data-read) ; + +M: bson-string element-data-read ( type -- object ) + drop + read-int32 read-sized-string ; + +M: bson-integer element-data-read ( type -- object ) + drop + read-int32 ; + +M: bson-double element-data-read ( type -- double ) + drop + read-double ; + +M: bson-boolean element-data-read ( type -- boolean ) + drop + read-byte 1 = ; + +M: bson-date element-data-read ( type -- timestamp ) + drop + read-longlong millis>timestamp ; + +M: bson-binary element-data-read ( type -- binary ) + drop + read-int32 read-byte element-binary-read ; + +M: bson-regexp element-data-read ( type -- mdbregexp ) + drop mdbregexp new + read-cstring >>regexp read-cstring >>options ; + +M: bson-null element-data-read ( type -- bf ) + drop + f ; + +M: bson-oid element-data-read ( type -- oid ) + drop + read-longlong + read-int32 oid boa ; + +M: bson-binary-custom element-binary-read ( size type -- dbref ) + 2drop + read-cstring + read-cstring objref boa ; + +M: bson-binary-bytes element-binary-read ( size type -- bytes ) + drop read ; + +M: bson-binary-function element-binary-read ( size type -- quot ) + drop read bytes>object ; + +PRIVATE> + +: stream>assoc ( exemplar -- assoc bytes-read ) + dup state + [ read-int32 >>size read-elements ] with-variable + [ result>> ] [ read>> ] bi ; diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor new file mode 100644 index 0000000000..1b9d45b124 --- /dev/null +++ b/extra/bson/writer/writer.factor @@ -0,0 +1,164 @@ +! Copyright (C) 2008 Sascha Matzke. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs bson.constants byte-arrays byte-vectors +calendar fry io io.binary io.encodings io.encodings.binary +io.encodings.utf8 io.streams.byte-array kernel math math.parser +namespaces quotations sequences sequences.private serialize strings +words combinators.short-circuit literals ; + +IN: bson.writer + + [ shared-buffer set ] keep ] unless* ; inline + +: >le-stream ( x n -- ) + swap + '[ _ swap nth-byte 0 B{ 0 } + [ set-nth-unsafe ] keep write ] each ; inline + +PRIVATE> + +: reset-buffer ( buffer -- ) + 0 >>length drop ; inline + +: ensure-buffer ( -- ) + (buffer) drop ; inline + +: with-buffer ( quot -- byte-vector ) + [ (buffer) [ reset-buffer ] keep dup ] dip + with-output-stream* dup encoder? [ stream>> ] when ; inline + +: with-length ( quot: ( -- ) -- bytes-written start-index ) + [ (buffer) [ length ] keep ] dip call + length swap [ - ] keep ; inline + +: with-length-prefix ( quot: ( -- ) -- ) + [ B{ 0 0 0 0 } write ] prepose with-length + [ INT32-SIZE >le ] dip (buffer) + '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] + [ INT32-SIZE ] dip each-integer ; inline + +: with-length-prefix-excl ( quot: ( -- ) -- ) + [ B{ 0 0 0 0 } write ] prepose with-length + [ INT32-SIZE - INT32-SIZE >le ] dip (buffer) + '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] + [ INT32-SIZE ] dip each-integer ; inline + + stream-write ; inline + +: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline +: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline +: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline +: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline +: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline + +: write-eoo ( -- ) T_EOO write-byte ; inline +: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline +: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline + +M: f bson-write ( f -- ) + drop 0 write-byte ; + +M: t bson-write ( t -- ) + drop 1 write-byte ; + +M: string bson-write ( obj -- ) + '[ _ write-cstring ] with-length-prefix-excl ; + +M: integer bson-write ( num -- ) + write-int32 ; + +M: real bson-write ( num -- ) + >float write-double ; + +M: timestamp bson-write ( timestamp -- ) + timestamp>millis write-longlong ; + +M: byte-array bson-write ( binary -- ) + [ length write-int32 ] keep + T_Binary_Bytes write-byte + write ; + +M: quotation bson-write ( quotation -- ) + object>bytes [ length write-int32 ] keep + T_Binary_Function write-byte + write ; + +M: oid bson-write ( oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; + +M: objref bson-write ( objref -- ) + [ binary ] dip + '[ _ + [ ns>> write-cstring ] + [ objid>> write-cstring ] bi ] with-byte-writer + [ length write-int32 ] keep + T_Binary_Custom write-byte write ; + +M: mdbregexp bson-write ( regexp -- ) + [ regexp>> write-cstring ] + [ options>> write-cstring ] bi ; + +M: sequence bson-write ( array -- ) + '[ _ [ [ write-type ] dip number>string + write-cstring bson-write ] each-index + write-eoo ] with-length-prefix ; + +: write-oid ( assoc -- ) + [ MDB_OID_FIELD ] dip at + [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline + +: skip-field? ( name -- boolean ) + { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline + +M: assoc bson-write ( assoc -- ) + '[ _ [ write-oid ] keep + [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each + write-eoo ] with-length-prefix ; + +M: word bson-write name>> bson-write ; + +PRIVATE> + +: assoc>bv ( assoc -- byte-vector ) + [ '[ _ bson-write ] with-buffer ] with-scope ; inline + +: assoc>stream ( assoc -- ) + bson-write ; inline + +: mdb-special-value? ( value -- ? ) + { [ timestamp? ] [ quotation? ] [ mdbregexp? ] + [ oid? ] [ byte-array? ] } 1|| ; \ No newline at end of file diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index eff95bbcd6..274e99d2f6 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -2,10 +2,37 @@ USING: kernel io strings byte-arrays sequences namespaces math parser crypto.hmac tools.test ; IN: crypto.hmac.tests -[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" byte-array>md5-hmac >string ] unit-test -[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test -[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>md5-hmac >string ] unit-test +[ + "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" +] [ + 16 11 "Hi There" sequence>md5-hmac >string ] unit-test -[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test -[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test -[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test +[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] +[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test + +[ + "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" +] +[ + 16 HEX: aa + 50 HEX: dd sequence>md5-hmac >string +] unit-test + +[ + "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" +] [ + 16 11 "Hi There" sequence>sha1-hmac >string +] unit-test + +[ + "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" +] [ + "Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string +] unit-test + +[ + "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" +] [ + 16 HEX: aa + 50 HEX: dd sequence>sha1-hmac >string +] unit-test diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 73b15b9473..6e6229f182 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -6,6 +6,8 @@ io.streams.byte-array kernel math math.vectors memoize sequences io.encodings.binary ; IN: crypto.hmac +sha1 get-sha1 @@ -24,6 +26,7 @@ IN: crypto.hmac [ bitxor ] 2map ; MEMO: ipad ( -- seq ) 64 HEX: 36 ; + MEMO: opad ( -- seq ) 64 HEX: 5c ; : init-hmac ( K -- o i ) @@ -31,13 +34,15 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; [ opad seq-bitxor ] keep ipad seq-bitxor ; +PRIVATE> + : stream>sha1-hmac ( K stream -- hmac ) [ init-hmac sha1-hmac ] with-input-stream ; : file>sha1-hmac ( K path -- hmac ) binary stream>sha1-hmac ; -: byte-array>sha1-hmac ( K string -- hmac ) +: sequence>sha1-hmac ( K sequence -- hmac ) binary stream>sha1-hmac ; : stream>md5-hmac ( K stream -- hmac ) @@ -46,5 +51,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : file>md5-hmac ( K path -- hmac ) binary stream>md5-hmac ; -: byte-array>md5-hmac ( K string -- hmac ) +: sequence>md5-hmac ( K sequence -- hmac ) binary stream>md5-hmac ; diff --git a/extra/drills/deployed/deploy.factor b/extra/drills/deployed/deploy.factor new file mode 100644 index 0000000000..2f62912360 --- /dev/null +++ b/extra/drills/deployed/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-unicode? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-name "drills" } + { deploy-ui? t } + { deploy-compiler? t } + { "stop-after-last-window?" t } + { deploy-word-props? f } + { deploy-c-types? f } + { deploy-io 2 } + { deploy-word-defs? f } + { deploy-reflection 1 } +} diff --git a/extra/drills/deployed/deployed.factor b/extra/drills/deployed/deployed.factor new file mode 100644 index 0000000000..43873c99bb --- /dev/null +++ b/extra/drills/deployed/deployed.factor @@ -0,0 +1,36 @@ +USING: accessors arrays cocoa.dialogs combinators continuations +fry grouping io.encodings.utf8 io.files io.styles kernel math +math.parser models models.arrow models.history namespaces random +sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras +ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames +ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts +wrap.strings system ; + +IN: drills.deployed +SYMBOLS: it startLength ; +: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ; +: card ( model quot -- button ) big [ next ] ; +: op ( quot str -- gadget )