diff --git a/README.txt b/README.txt index 12dade5ba1..dd7c3e7ad3 100755 --- a/README.txt +++ b/README.txt @@ -6,7 +6,6 @@ implementation. It is not an introduction to the language itself. * Contents -- Platform support - Compiling the Factor VM - Libraries needed for compilation - Bootstrapping the Factor image @@ -19,80 +18,50 @@ implementation. It is not an introduction to the language itself. - Source organization - Community -* Platform support - -Factor supports the following platforms: - - Linux/x86 - Linux/AMD64 - Linux/PowerPC - Linux/ARM - Mac OS X/x86 - Mac OS X/PowerPC - FreeBSD/x86 - FreeBSD/AMD64 - OpenBSD/x86 - OpenBSD/AMD64 - Solaris/x86 - Solaris/AMD64 - MS Windows/x86 (XP and above) - MS Windows CE/ARM - -Please donate time or hardware if you wish to see Factor running on -other platforms. In particular, we are interested in: - - Windows/AMD64 - Mac OS X/AMD64 - Solaris/UltraSPARC - Linux/MIPS - * Compiling the Factor VM The Factor runtime is written in GNU C99, and is built with GNU make and gcc. -Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc -3.3 or earlier. If you are using gcc 4.3, you might get an unusable -Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the -command-line arguments for make. +Factor supports various platforms. For an up-to-date list, see +. -Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of -targets and build options. Then run 'make' with the appropriate target -for your platform. +Factor requires gcc 3.4 or later. + +On x86, Factor /will not/ build using gcc 3.3 or earlier. + +If you are using gcc 4.3, you might get an unusable Factor binary unless +you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line +arguments for make. + +Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. Compilation will yield an executable named 'factor' on Unix, -'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE. +'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE. * Libraries needed for compilation -For X11 support, you need recent development libraries for libc, Freetype, -X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu), -you can use the line +For X11 support, you need recent development libraries for libc, +Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution +(like Ubuntu), you can use the line -sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev + sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev -to grab everything (if you're on a non-debian-derived distro please tell us -what the equivalent command is on there and it can be added :) +to grab everything (if you're on a non-debian-derived distro please tell +us what the equivalent command is on there and it can be added). * Bootstrapping the Factor image -The boot images are no longer included with the Factor distribution -due to size concerns. Instead, download a boot image from: - - http://factorcode.org/images/ - Once you have compiled the Factor runtime, you must bootstrap the Factor system using the image that corresponds to your CPU architecture. -Once you download the right image, bootstrap the system with the +Boot images can be obtained from . + +Once you download the right image, bootstrap Factor with the following command line: ./factor -i=boot..image -Or this command for Mac OS X systems: - -./Factor.app/Contents/MacOS/factor -i=boot..image - Bootstrap can take a while, depending on your system. When the process completes, a 'factor.image' file will be generated. Note that this image is both CPU and OS-specific, so in general cannot be shared between @@ -122,9 +91,8 @@ The latter keeps the terminal listener running. * Running Factor on Mac OS X - Cocoa UI -On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the -terminal listener. If you are using Mac OS X 10.3, you can only run the -X11 UI, as documented in the next section. +On Mac OS X, a Cocoa UI is available in addition to the terminal +listener. The 'factor' executable runs the terminal listener: @@ -136,17 +104,16 @@ contains factor.image and the library sources. * Running Factor on Mac OS X - X11 UI -The X11 UI is available on Mac OS X, however its use is not recommended -since it does not integrate with the host OS. However, if you are -running Mac OS X 10.3, it is your only choice. +The X11 UI is also available on Mac OS X, however its use is not +recommended since it does not integrate with the host OS. When compiling Factor, pass the X11=1 parameter: - make macosx-ppc X11=1 + make X11=1 Then bootstrap with the following switches: - ./factor -i=boot.ppc.image -ui-backend=x11 + ./factor -i=boot..image -ui-backend=x11 Now if $DISPLAY is set, running ./factor will start the UI. @@ -155,40 +122,36 @@ Now if $DISPLAY is set, running ./factor will start the UI. If you did not download the binary package, you can bootstrap Factor in the command prompt: - factor-nt.exe -i=boot.x86.32.image + factor.exe -i=boot..image Once bootstrapped, double-clicking factor.exe starts the Factor UI. To run the listener in the command prompt: - factor-nt.exe -run=listener + factor.exe -run=listener * The Factor FAQ -The Factor FAQ lives online at http://factorcode.org/faq.fhtml +The Factor FAQ is available at . * Command line usage -The Factor VM supports a number of command line switches. To read -command line usage documentation, either enter the following in the UI -listener: +Factor supports a number of command line switches. To read command line +usage documentation, enter the following in the UI listener: "command-line" about * Source organization -The following two directories are managed by the module system; consult -the documentation for details: +The Factor source tree is organized as follows: + build-support/ - scripts used for compiling Factor core/ - Factor core library and compiler extra/ - more libraries - -The following directories contain additional files: - - misc/ - editor modes, icons, etc - vm/ - sources for the Factor runtime, written in C fonts/ - TrueType fonts used by UI + misc/ - editor modes, icons, etc unmaintained/ - unmaintained contributions, please help! + vm/ - sources for the Factor VM, written in C * Community diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 136af91bb2..7d13080e3c 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -78,7 +78,7 @@ $nl "<< \"freetype\" {" " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" - " { [ t ] [ drop ] }" + " [ drop ]" "} cond >>" } "Note the parse time evaluation with " { $link POSTPONE: << } "." } ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 2f82e5db98..f664e1175a 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -54,7 +54,7 @@ TUPLE: library path abi dll ; : library ( name -- library ) libraries get at ; : ( path abi -- library ) - over dup [ dlopen ] when \ library construct-boa ; + over dup [ dlopen ] when \ library boa ; : load-library ( name -- dll ) library dup [ library-dll ] when ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 508fcd61a6..c97c760695 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -18,12 +18,12 @@ boxer prep unboxer getter setter reg-class size align stack-align? ; -: construct-c-type ( class -- type ) - construct-empty +: new-c-type ( class -- type ) + new int-regs >>reg-class ; : ( -- type ) - \ c-type construct-c-type ; + \ c-type new-c-type ; SYMBOL: c-types @@ -189,7 +189,7 @@ DEFER: >c-ushort-array TUPLE: long-long-type < c-type ; : ( -- type ) - long-long-type construct-c-type ; + long-long-type new-c-type ; M: long-long-type unbox-parameter ( n type -- ) c-type-unboxer %unbox-long-long ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 0f74f52d60..b6fcbe6176 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -220,7 +220,7 @@ M: no-such-library compiler-error-type drop +linkage+ ; : no-such-library ( name -- ) - \ no-such-library construct-boa + \ no-such-library boa compiling-word get compiler-error ; TUPLE: no-such-symbol name ; @@ -232,7 +232,7 @@ M: no-such-symbol compiler-error-type drop +linkage+ ; : no-such-symbol ( name -- ) - \ no-such-symbol construct-boa + \ no-such-symbol boa compiling-word get compiler-error ; : check-dlsym ( symbols dll -- ) @@ -251,7 +251,7 @@ M: no-such-symbol compiler-error-type \ alien-invoke [ ! Four literals 4 ensure-values - #alien-invoke construct-empty + #alien-invoke new ! Compile-time parameters pop-parameters >>parameters pop-literal nip >>function @@ -288,7 +288,7 @@ M: alien-indirect-error summary ! Three literals and function pointer 4 ensure-values 4 reify-curries - #alien-indirect construct-empty + #alien-indirect new ! Compile-time parameters pop-literal nip >>abi pop-parameters >>parameters @@ -335,7 +335,7 @@ M: alien-callback-error summary \ alien-callback [ 4 ensure-values - #alien-callback construct-empty dup node, + #alien-callback new dup node, pop-literal nip >>quot pop-literal nip >>abi pop-parameters >>parameters @@ -375,13 +375,13 @@ TUPLE: callback-context ; return>> { { [ dup "void" = ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } - { [ t ] [ c-type c-type-prep ] } + [ c-type c-type-prep ] } cond ; : wrap-callback-quot ( node -- quot ) [ [ quot>> ] [ prepare-callback-return ] bi append , - [ callback-context construct-empty do-callback ] % + [ callback-context new do-callback ] % ] [ ] make ; : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ; @@ -390,7 +390,7 @@ TUPLE: callback-context ; { { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } { [ dup return>> large-struct? ] [ drop 4 ] } - { [ t ] [ drop 0 ] } + [ drop 0 ] } cond ; : %callback-return ( node -- ) diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index 491f4351a3..6d98d31790 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -68,7 +68,7 @@ M: struct-type stack-size : (define-struct) ( name vocab size align fields -- ) >r [ align ] keep r> - struct-type construct-boa + struct-type boa -rot define-c-type ; : make-field ( struct-name vocab type field-name -- spec ) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 6e4b8b4e21..67ea30f379 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -68,7 +68,7 @@ M: alien pprint* { { [ dup expired? ] [ drop "( alien expired )" text ] } { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } - { [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } + [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } cond ; M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ; diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 414c64581e..9c5f40d883 100755 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -12,9 +12,9 @@ M: array resize resize-array ; : >array ( seq -- array ) { } clone-like ; -M: object new drop f ; +M: object new-sequence drop f ; -M: f new drop dup zero? [ drop f ] [ f ] if ; +M: f new-sequence drop dup zero? [ drop f ] [ f ] if ; M: array like drop dup array? [ >array ] unless ; diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index e85789a4f2..863fdaecb3 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -69,14 +69,14 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs" ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)." { $subsection subassoc? } -{ $subsection intersect } +{ $subsection assoc-intersect } { $subsection update } -{ $subsection union } -{ $subsection diff } +{ $subsection assoc-union } +{ $subsection assoc-diff } { $subsection remove-all } { $subsection substitute } { $subsection substitute-here } -{ $see-also key? } ; +{ $see-also key? assoc-contains? assoc-all? "sets" } ; ARTICLE: "assocs-mutation" "Storing keys and values in assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" @@ -97,6 +97,7 @@ $nl { $subsection assoc-map } { $subsection assoc-push-if } { $subsection assoc-subset } +{ $subsection assoc-contains? } { $subsection assoc-all? } "Three additional combinators:" { $subsection cache } @@ -206,9 +207,13 @@ HELP: assoc-subset { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } } { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ; +HELP: assoc-contains? +{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } } +{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ; + HELP: assoc-all? { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } } -{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ; +{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ; HELP: subassoc? { $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } } @@ -260,7 +265,7 @@ HELP: values { keys values } related-words -HELP: intersect +HELP: assoc-intersect { $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } } { $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." } { $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ; @@ -270,11 +275,11 @@ HELP: update { $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." } { $side-effects "assoc1" } ; -HELP: union +HELP: assoc-union { $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } } { $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ; -HELP: diff +HELP: assoc-diff { $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } } { $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." } ; diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index c4db604784..76f484006d 100755 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -58,24 +58,24 @@ H{ } clone "cache-test" set ] [ H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } } H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } } - intersect + assoc-intersect ] unit-test [ H{ { 1 2 } { 2 3 } { 6 5 } } ] [ H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } } - union + assoc-union ] unit-test [ H{ { 1 2 } { 2 3 } } t ] [ - f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd = + f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd = ] unit-test [ H{ { 1 f } } ] [ - H{ { 1 f } } H{ { 1 f } } intersect + H{ { 1 f } } H{ { 1 f } } assoc-intersect ] unit-test [ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index adb69d317c..4a6ecae4fe 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -109,17 +109,17 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) >r over r> hashcode* 2/ >r dupd hashcode* r> bitxor ] { } assoc>map hashcode* ; -: intersect ( assoc1 assoc2 -- intersection ) +: assoc-intersect ( assoc1 assoc2 -- intersection ) swap [ nip key? ] curry assoc-subset ; : update ( assoc1 assoc2 -- ) swap [ swapd set-at ] curry assoc-each ; -: union ( assoc1 assoc2 -- union ) +: assoc-union ( assoc1 assoc2 -- union ) 2dup [ assoc-size ] bi@ + pick new-assoc [ rot update ] keep [ swap update ] keep ; -: diff ( assoc1 assoc2 -- diff ) +: assoc-diff ( assoc1 assoc2 -- diff ) swap [ nip key? not ] curry assoc-subset ; : remove-all ( assoc seq -- subseq ) diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index ee485d399e..ffb9f5d195 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -43,7 +43,7 @@ M: bit-array clone (clone) ; M: bit-array like drop dup bit-array? [ >bit-array ] unless ; -M: bit-array new drop ; +M: bit-array new-sequence drop ; M: bit-array equal? over bit-array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor index c418a24813..db941ac6f7 100755 --- a/core/bit-vectors/bit-vectors.factor +++ b/core/bit-vectors/bit-vectors.factor @@ -7,7 +7,7 @@ IN: bit-vectors vector ( bit-array length -- bit-vector ) - bit-vector construct-boa ; inline + bit-vector boa ; inline PRIVATE> @@ -22,7 +22,7 @@ M: bit-vector like [ dup length bit-array>vector ] [ >bit-vector ] if ] unless ; -M: bit-vector new +M: bit-vector new-sequence drop [ ] keep >fixnum bit-array>vector ; M: bit-vector equal? diff --git a/core/bit-vectors/summary.txt b/core/bit-vectors/summary.txt new file mode 100644 index 0000000000..76a7d0f1cc --- /dev/null +++ b/core/bit-vectors/summary.txt @@ -0,0 +1 @@ +Growable bit arrays diff --git a/core/bit-vectors/tags.txt b/core/bit-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/bit-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 9e101126e6..da3c634ebd 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -53,7 +53,7 @@ nl "." write flush { - new nth push pop peek + new-sequence nth push pop peek } compile "." write flush diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index ceb011d52b..e839576bc9 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -36,4 +36,4 @@ tag-numbers get H{ { word 17 } { byte-array 18 } { tuple-layout 19 } -} union type-numbers set +} assoc-union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 9d3c28b068..f1e41ac2b6 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -390,7 +390,7 @@ define-builtin ! Create special tombstone values "tombstone" "hashtables.private" create -"tuple" "kernel" lookup +tuple { } define-tuple-class "((empty))" "hashtables.private" create @@ -403,7 +403,7 @@ define-builtin ! Some tuple classes "hashtable" "hashtables" create -"tuple" "kernel" lookup +tuple { { { "array-capacity" "sequences.private" } @@ -424,7 +424,7 @@ define-builtin } define-tuple-class "sbuf" "sbufs" create -"tuple" "kernel" lookup +tuple { { { "string" "strings" } @@ -440,7 +440,7 @@ define-builtin } define-tuple-class "vector" "vectors" create -"tuple" "kernel" lookup +tuple { { { "array" "arrays" } @@ -456,7 +456,7 @@ define-builtin } define-tuple-class "byte-vector" "byte-vectors" create -"tuple" "kernel" lookup +tuple { { { "byte-array" "byte-arrays" } @@ -472,7 +472,7 @@ define-builtin } define-tuple-class "bit-vector" "bit-vectors" create -"tuple" "kernel" lookup +tuple { { { "bit-array" "bit-arrays" } @@ -488,7 +488,7 @@ define-builtin } define-tuple-class "float-vector" "float-vectors" create -"tuple" "kernel" lookup +tuple { { { "float-array" "float-arrays" } @@ -504,7 +504,7 @@ define-builtin } define-tuple-class "curry" "kernel" create -"tuple" "kernel" lookup +tuple { { { "object" "kernel" } @@ -525,7 +525,7 @@ define-builtin [ tuple-layout [ ] curry ] tri define "compose" "kernel" create -"tuple" "kernel" lookup +tuple { { { "object" "kernel" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index a75b111e78..ca90587ea9 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -5,7 +5,7 @@ kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings definitions assocs compiler.errors compiler.units -math.parser generic ; +math.parser generic sets ; IN: bootstrap.stage2 SYMBOL: bootstrap-time @@ -24,7 +24,7 @@ SYMBOL: bootstrap-time : load-components ( -- ) "exclude" "include" [ get-global " " split [ empty? not ] subset ] bi@ - seq-diff + diff [ "bootstrap." prepend require ] each ; ! : compile-remaining ( -- ) diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index a989e091bb..b56a46b6b3 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -5,7 +5,7 @@ IN: boxes TUPLE: box value full? ; -: ( -- box ) box construct-empty ; +: ( -- box ) box new ; : >box ( value box -- ) dup box-full? [ "Box already has a value" throw ] when diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 548c293e7c..d603470810 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -10,7 +10,7 @@ M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline M: byte-array like drop dup byte-array? [ >byte-array ] unless ; -M: byte-array new drop ; +M: byte-array new-sequence drop ; M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index 6a08f657a2..206a23f43b 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -7,7 +7,7 @@ IN: byte-vectors vector ( byte-array length -- byte-vector ) - byte-vector construct-boa ; inline + byte-vector boa ; inline PRIVATE> @@ -22,7 +22,7 @@ M: byte-vector like [ dup length byte-array>vector ] [ >byte-vector ] if ] unless ; -M: byte-vector new +M: byte-vector new-sequence drop [ ] keep >fixnum byte-array>vector ; M: byte-vector equal? diff --git a/core/byte-vectors/summary.txt b/core/byte-vectors/summary.txt new file mode 100644 index 0000000000..e914ebb319 --- /dev/null +++ b/core/byte-vectors/summary.txt @@ -0,0 +1 @@ +Growable byte arrays diff --git a/core/byte-vectors/tags.txt b/core/byte-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/byte-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 4614e4c4ce..b7a3e074e5 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel classes classes.builtin combinators accessors sequences arrays vectors assocs namespaces words sorting layouts -math hashtables kernel.private ; +math hashtables kernel.private sets ; IN: classes.algebra : 2cache ( key1 key2 assoc quot -- value ) @@ -84,7 +84,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup members ] [ right-union-class< ] } { [ over superclass ] [ superclass< ] } - { [ t ] [ 2drop f ] } + [ 2drop f ] } cond ; : anonymous-union-intersect? ( first second -- ? ) @@ -104,14 +104,14 @@ C: anonymous-complement { [ over tuple eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] } - { [ t ] [ swap classes-intersect? ] } + [ swap classes-intersect? ] } cond ; : builtin-class-intersect? ( first second -- ? ) { { [ 2dup eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } - { [ t ] [ swap classes-intersect? ] } + [ swap classes-intersect? ] } cond ; : (classes-intersect?) ( first second -- ? ) @@ -154,7 +154,7 @@ C: anonymous-complement { [ over members ] [ left-union-and ] } { [ over anonymous-union? ] [ left-anonymous-union-and ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : left-anonymous-union-or ( first second -- class ) @@ -169,7 +169,7 @@ C: anonymous-complement { [ 2dup swap class< ] [ drop ] } { [ dup anonymous-union? ] [ right-anonymous-union-or ] } { [ over anonymous-union? ] [ left-anonymous-union-or ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : (class-not) ( class -- complement ) @@ -177,7 +177,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> ] } { [ dup object eq? ] [ drop null ] } { [ dup null eq? ] [ drop object ] } - { [ t ] [ ] } + [ ] } cond ; : largest-class ( seq -- n elt ) @@ -205,7 +205,7 @@ C: anonymous-complement { [ dup builtin-class? ] [ dup set ] } { [ dup members ] [ members [ (flatten-class) ] each ] } { [ dup superclass ] [ superclass (flatten-class) ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : flatten-class ( class -- assoc ) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index b22e21eb92..4f43b86f64 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -89,7 +89,7 @@ M: word reset-class drop ; dup reset-class dup deferred? [ dup define-symbol ] when dup word-props - r> union over set-word-props + r> assoc-union over set-word-props dup predicate-word [ 1quotation "predicate" set-word-prop ] [ swap "predicating" set-word-prop ] diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index aefd522269..33b0fc32fa 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -24,7 +24,7 @@ TUPLE: check-mixin-class mixin ; : check-mixin-class ( mixin -- mixin ) dup mixin-class? [ - \ check-mixin-class construct-boa throw + \ check-mixin-class boa throw ] unless ; : if-mixin-member? ( class mixin true false -- ) @@ -49,7 +49,7 @@ M: mixin-instance equal? { [ over mixin-instance? not ] [ f ] } { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; M: mixin-instance hashcode* diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 5d35afb7d3..cdfdee9717 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -4,7 +4,7 @@ generic.standard sequences definitions compiler.units ; IN: classes.tuple ARTICLE: "parametrized-constructors" "Parameterized constructors" -"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack." +"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack." $nl "Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:" { $code @@ -14,14 +14,14 @@ $nl "" "TUPLE: car < vehicle engine ;" ": ( max-speed engine -- car )" - " car construct-empty" + " car new" " V{ } clone >>occupants" " swap >>engine" " swap >>max-speed ;" "" "TUPLE: aeroplane < vehicle max-altitude ;" ": ( max-speed max-altitude -- aeroplane )" - " aeroplane construct-empty" + " aeroplane new" " V{ } clone >>occupants" " swap >>max-altitude" " swap >>max-speed ;" @@ -32,28 +32,28 @@ $nl "" ": add-occupant ( person vehicle -- ) occupants>> push ;" "" - ": construct-vehicle ( class -- vehicle )" - " construct-empty" + ": new-vehicle ( class -- vehicle )" + " new" " V{ } clone >>occupants ;" "" "TUPLE: car < vehicle engine ;" ": ( max-speed engine -- car )" - " car construct-vehicle" + " car new-vehicle" " swap >>engine" " swap >>max-speed ;" "" "TUPLE: aeroplane < vehicle max-altitude ;" ": ( max-speed max-altitude -- aeroplane )" - " aeroplane construct-vehicle" + " aeroplane new-vehicle" " swap >>max-altitude" " swap >>max-speed ;" } -"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ; +"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ; ARTICLE: "tuple-constructors" "Tuple constructors" "Tuples are created by calling one of two constructor primitives:" -{ $subsection construct-empty } -{ $subsection construct-boa } +{ $subsection new } +{ $subsection boa } "A shortcut for defining BOA constructors:" { $subsection POSTPONE: C: } "By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "" } "." @@ -64,13 +64,16 @@ $nl { $code "TUPLE: color red green blue alpha ;" "" + "! The following two are equivalent" "C: rgba" - ": color construct-boa ; ! identical to above" + ": color boa ;" "" + "! We can define constructors which call other constructors" ": f ;" "" - ": construct-empty ;" - ": f f f f ; ! identical to above" + "! The following two are equivalent" + ": color new ;" + ": f f f f ;" } { $subsection "parametrized-constructors" } ; @@ -129,7 +132,7 @@ $nl $nl "The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes." { $heading "Anti-pattern #3: subclassing to override a method definition" } -"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link construct-empty } ", " { $link construct-boa } ", or a custom parametrized constructor." +"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor." { $see-also "parametrized-constructors" } ; ARTICLE: "tuple-subclassing" "Tuple subclassing" @@ -164,11 +167,11 @@ ARTICLE: "tuple-examples" "Tuple examples" } "We can define a constructor which makes an empty employee:" { $code ": ( -- employee )" - " employee construct-empty ;" } + " employee new ;" } "Or we may wish the default constructor to always give employees a starting salary:" { $code ": ( -- employee )" - " employee construct-empty" + " employee new" " 40000 >>salary ;" } "We can define more refined constructors:" @@ -178,7 +181,7 @@ ARTICLE: "tuple-examples" "Tuple examples" "An alternative strategy is to define the most general BOA constructor first:" { $code ": ( name position -- person )" - " 40000 employee construct-boa ;" + " 40000 employee boa ;" } "Now we can define more specific constructors:" { $code @@ -191,7 +194,7 @@ ARTICLE: "tuple-examples" "Tuple examples" "SYMBOL: checks" "" ": ( to amount -- check )" - " checks counter check construct-boa ;" + " checks counter check boa ;" "" ": biweekly-paycheck ( employee -- check )" " dup name>> swap salary>> 26 / ;" @@ -326,20 +329,20 @@ HELP: tuple>array ( tuple -- array ) HELP: ( layout -- tuple ) { $values { "layout" tuple-layout } { "tuple" tuple } } -{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ; +{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ; HELP: ( ... layout -- tuple ) { $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } } -{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ; +{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ; -HELP: construct-empty +HELP: new { $values { "class" tuple-class } { "tuple" tuple } } { $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." } { $examples { $example "USING: kernel prettyprint ;" "TUPLE: employee number name department ;" - "employee construct-empty ." + "employee new ." "T{ employee f f f f }" } } ; @@ -361,12 +364,12 @@ HELP: construct " color construct ;" } "The last definition is actually equivalent to the following:" - { $code ": ( r g b a -- color ) rgba construct-boa ;" } + { $code ": ( r g b a -- color ) rgba boa ;" } "Which can be abbreviated further:" { $code "C: color" } } ; -HELP: construct-boa +HELP: boa { $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } } { $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." } -{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ; +{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 2575570d2f..ce6fd9367c 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -7,7 +7,7 @@ calendar prettyprint io.streams.string splitting inspector ; IN: classes.tuple.tests TUPLE: rect x y w h ; -: rect construct-boa ; +: rect boa ; : move ( x rect -- rect ) [ + ] change-x ; @@ -198,8 +198,8 @@ SYMBOL: not-a-tuple-class ] unit-test ! Missing check -[ not-a-tuple-class construct-boa ] must-fail -[ not-a-tuple-class construct-empty ] must-fail +[ not-a-tuple-class boa ] must-fail +[ not-a-tuple-class new ] must-fail TUPLE: erg's-reshape-problem a b c d ; @@ -207,8 +207,8 @@ C: erg's-reshape-problem ! We want to make sure constructors are recompiled when ! tuples are reshaped -: cons-test-1 \ erg's-reshape-problem construct-empty ; -: cons-test-2 \ erg's-reshape-problem construct-boa ; +: cons-test-1 \ erg's-reshape-problem new ; +: cons-test-2 \ erg's-reshape-problem boa ; "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval @@ -538,3 +538,6 @@ TUPLE: another-forget-accessors-test ; ] with-string-writer empty? ] with-variable ] unit-test + +! Missing error check +[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index aa8ef6cdb7..c14205e1d9 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -58,6 +58,8 @@ PRIVATE> : all-slot-names ( class -- slots ) superclasses [ slot-names ] map concat \ class prefix ; +ERROR: bad-superclass class ; + GENERIC# define-tuple-class 2 ( class superclass slots -- ) M: word define-tuple-class + over check-superclass define-new-tuple-class ; M: tuple-class define-tuple-class 3dup tuple-class-unchanged? - [ 3dup redefine-tuple-class ] unless + [ over check-superclass 3dup redefine-tuple-class ] unless 3drop ; : define-error-class ( class superclass slots -- ) [ define-tuple-class ] [ 2drop ] 3bi - dup [ construct-boa throw ] curry define ; + dup [ boa throw ] curry define ; M: tuple-class reset-class [ diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index f497fd20e5..54c62c44fa 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -64,9 +64,9 @@ HELP: alist>quot { $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ; HELP: cond -{ $values { "assoc" "a sequence of quotation pairs" } } +{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } } { $description - "Calls the second quotation in the first pair whose first quotation yields a true value." + "Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value." $nl "The following two phrases are equivalent:" { $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" } @@ -78,7 +78,7 @@ HELP: cond "{" " { [ dup 0 > ] [ \"positive\" ] }" " { [ dup 0 < ] [ \"negative\" ] }" - " { [ dup zero? ] [ \"zero\" ] }" + " [ \"zero\" ]" "} cond" } } ; @@ -88,9 +88,9 @@ HELP: no-cond { $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ; HELP: case -{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } } +{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } } { $description - "Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation." + "Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation." $nl "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied." $nl diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 8abc53e43f..b612669b71 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,7 +1,54 @@ -IN: combinators.tests USING: alien strings kernel math tools.test io prettyprint -namespaces combinators words ; +namespaces combinators words classes sequences ; +IN: combinators.tests +! Compiled +: cond-test-1 ( obj -- str ) + { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond ; + +\ cond-test-1 must-infer + +[ "even" ] [ 2 cond-test-1 ] unit-test +[ "odd" ] [ 3 cond-test-1 ] unit-test + +: cond-test-2 ( obj -- str ) + { + { [ dup t = ] [ drop "true" ] } + { [ dup f = ] [ drop "false" ] } + [ drop "something else" ] + } cond ; + +\ cond-test-2 must-infer + +[ "true" ] [ t cond-test-2 ] unit-test +[ "false" ] [ f cond-test-2 ] unit-test +[ "something else" ] [ "ohio" cond-test-2 ] unit-test + +: cond-test-3 ( obj -- str ) + { + [ drop "something else" ] + { [ dup t = ] [ drop "true" ] } + { [ dup f = ] [ drop "false" ] } + } cond ; + +\ cond-test-3 must-infer + +[ "something else" ] [ t cond-test-3 ] unit-test +[ "something else" ] [ f cond-test-3 ] unit-test +[ "something else" ] [ "ohio" cond-test-3 ] unit-test + +: cond-test-4 ( -- ) + { + } cond ; + +\ cond-test-4 must-infer + +[ cond-test-4 ] [ class \ no-cond = ] must-fail-with + +! Interpreted [ "even" ] [ 2 { { [ dup 2 mod 0 = ] [ drop "even" ] } @@ -21,11 +68,66 @@ namespaces combinators words ; { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] unit-test -: case-test-1 +[ "neither" ] [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + [ drop "neither" ] + } cond +] unit-test + +[ "neither" ] [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + [ drop "neither" ] + } cond +] unit-test + +[ "early" ] [ + 2 { + { [ dup 2 mod 1 = ] [ drop "odd" ] } + [ drop "early" ] + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ "really early" ] [ + 2 { + [ drop "really early" ] + { [ dup 2 mod 1 = ] [ drop "odd" ] } + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ { } cond ] [ class \ no-cond = ] must-fail-with + +[ "early" ] [ + 2 { + { [ dup 2 mod 1 = ] [ drop "odd" ] } + [ drop "early" ] + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ "really early" ] [ + 2 { + [ drop "really early" ] + { [ dup 2 mod 1 = ] [ drop "odd" ] } + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ { } cond ] [ class \ no-cond = ] must-fail-with + +! Compiled +: case-test-1 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -33,6 +135,8 @@ namespaces combinators words ; { 4 [ "four" ] } } case ; +\ case-test-1 must-infer + [ "two" ] [ 2 case-test-1 ] unit-test ! Interpreted @@ -40,7 +144,7 @@ namespaces combinators words ; [ "x" case-test-1 ] must-fail -: case-test-2 +: case-test-2 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -49,12 +153,14 @@ namespaces combinators words ; [ sq ] } case ; +\ case-test-2 must-infer + [ 25 ] [ 5 case-test-2 ] unit-test ! Interpreted [ 25 ] [ 5 \ case-test-2 word-def call ] unit-test -: case-test-3 +: case-test-3 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -65,8 +171,122 @@ namespaces combinators words ; [ sq ] } case ; +\ case-test-3 must-infer + [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test +: case-const-1 1 ; +: case-const-2 2 ; inline + +! Compiled +: case-test-4 ( obj -- str ) + { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case ; + +\ case-test-4 must-infer + +[ "uno" ] [ 1 case-test-4 ] unit-test +[ "dos" ] [ 2 case-test-4 ] unit-test +[ "tres" ] [ 3 case-test-4 ] unit-test +[ "demasiado" ] [ 100 case-test-4 ] unit-test + +: case-test-5 ( obj -- ) + { + { case-const-1 [ "uno" print ] } + { case-const-2 [ "dos" print ] } + { 3 [ "tres" print ] } + { 4 [ "cuatro" print ] } + { 5 [ "cinco" print ] } + [ drop "demasiado" print ] + } case ; + +\ case-test-5 must-infer + +[ ] [ 1 case-test-5 ] unit-test + +! Interpreted +[ "uno" ] [ + 1 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "dos" ] [ + 2 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "tres" ] [ + 3 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "demasiado" ] [ + 100 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +: do-not-call "do not call" throw ; + +: test-case-6 + { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case ; + +[ "three" ] [ 3 test-case-6 ] unit-test +[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test + +[ "three" ] [ + 3 { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + +[ "do-not-call" ] [ + [ do-not-call ] first { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + +[ "do-not-call" ] [ + \ do-not-call { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + ! Interpreted [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 96c4009ba9..e3d0f88680 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -3,7 +3,7 @@ IN: combinators USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors -hashtables sorting ; +hashtables sorting words sets ; : cleave ( x seq -- ) [ call ] with each ; @@ -34,13 +34,24 @@ hashtables sorting ; ERROR: no-cond ; : cond ( assoc -- ) - [ first call ] find nip dup [ second call ] [ no-cond ] if ; + [ dup callable? [ drop t ] [ first call ] if ] find nip + [ dup callable? [ call ] [ second call ] if ] + [ no-cond ] if* ; ERROR: no-case ; +: case-find ( obj assoc -- obj' ) + [ + dup array? [ + dupd first dup word? [ + execute + ] [ + dup wrapper? [ wrapped ] when + ] if = + ] [ quotation? ] if + ] find nip ; : case ( obj assoc -- ) - [ dup array? [ dupd first = ] [ quotation? ] if ] find nip - { + case-find { { [ dup array? ] [ nip second call ] } { [ dup quotation? ] [ call ] } { [ dup not ] [ no-case ] } @@ -73,11 +84,14 @@ M: hashtable hashcode* [ rot \ if 3array append [ ] like ] assoc-each ; : cond>quot ( assoc -- quot ) + [ dup callable? [ [ t ] swap 2array ] when ] map reverse [ no-cond ] swap alist>quot ; : linear-case-quot ( default assoc -- quot ) - [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map - alist>quot ; + [ + [ 1quotation \ dup prefix \ = suffix ] + [ \ drop prefix ] bi* + ] assoc-map alist>quot ; : (distribute-buckets) ( buckets pair keys -- ) dup t eq? [ @@ -135,7 +149,9 @@ M: hashtable hashcode* dup empty? [ drop ] [ - dup length 4 <= [ + dup length 4 <= + over keys [ word? ] contains? or + [ linear-case-quot ] [ dup keys contiguous-range? [ diff --git a/core/command-line/command-line-docs.factor b/core/command-line/command-line-docs.factor index e41d316792..88ea43be20 100644 --- a/core/command-line/command-line-docs.factor +++ b/core/command-line/command-line-docs.factor @@ -7,9 +7,10 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM" { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } } { { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" } { { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" } - { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" } - { { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } } - { { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" } + { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" } + { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } } + { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" } + { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" } { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" } { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" } } diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 6f75ca873d..806ea914bb 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -20,7 +20,7 @@ IN: compiler : finish-compile ( word effect dependencies -- ) >r dupd save-effect r> over compiled-unxref - over crossref? [ compiled-xref ] [ 2drop ] if ; + over compiled-crossref? [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 09b0c190e6..dce2ec562a 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -187,7 +187,7 @@ DEFER: countdown-b { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] compile-call ] unit-test @@ -196,7 +196,7 @@ DEFER: countdown-b [ 3 { { [ dup fixnum? ] [ ] } - { [ t ] [ drop t ] } + [ drop t ] } cond ] compile-call ] unit-test diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index 97cde6261c..2b43ac6f56 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -4,16 +4,16 @@ USING: kernel tools.test compiler.units ; TUPLE: color red green blue ; [ T{ color f 1 2 3 } ] -[ 1 2 3 [ color construct-boa ] compile-call ] unit-test +[ 1 2 3 [ color boa ] compile-call ] unit-test [ 1 3 ] [ - 1 2 3 color construct-boa + 1 2 3 color boa [ { color-red color-blue } get-slots ] compile-call ] unit-test [ T{ color f 10 2 20 } ] [ 10 20 - 1 2 3 color construct-boa [ + 1 2 3 color boa [ [ { set-color-red set-color-blue } set-slots ] compile-call @@ -21,4 +21,4 @@ TUPLE: color red green blue ; ] unit-test [ T{ color f f f f } ] -[ [ color construct-empty ] compile-call ] unit-test +[ [ color new ] compile-call ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index a780e0a745..65e57a8912 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -10,7 +10,7 @@ SYMBOL: new-definitions TUPLE: redefine-error def ; : redefine-error ( definition -- ) - \ redefine-error construct-boa + \ redefine-error boa { { "Continue" t } } throw-restarts drop ; : add-once ( key assoc -- ) @@ -66,7 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- ) : compile ( words -- ) recompile-hook get call - dup [ drop crossref? ] assoc-contains? + dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap ; SYMBOL: outdated-tuples @@ -82,7 +82,7 @@ SYMBOL: update-tuples-hook : finish-compilation-unit ( -- ) call-recompile-hook call-update-tuples-hook - dup [ drop crossref? ] assoc-contains? modify-code-heap + dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap updated-definitions notify-definition-observers ; : with-compilation-unit ( quot -- ) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index b3adb1b165..b1db09b6bc 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -90,7 +90,11 @@ ABOUT: "continuations" HELP: dispose { $values { "object" "a disposable object" } } -{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." } +{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." +$nl +"No further operations can be performed on a disposable object after this call." +$nl +"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." } { $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ; HELP: with-disposal diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 7ea8849d30..65d1763ea8 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel kernel.private math memory namespaces sequences layouts system hashtables classes alien -byte-arrays bit-arrays float-arrays combinators words ; +byte-arrays bit-arrays float-arrays combinators words sets ; IN: cpu.architecture ! A pseudo-register class for parameters spilled on the stack diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 699670aecd..cc3fceff23 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -246,9 +246,8 @@ M: x86.32 %cleanup ( alien-node -- ) } { [ dup return>> large-struct? ] [ drop EAX PUSH ] - } { - [ t ] [ drop ] } + [ drop ] } cond ; M: x86.32 %unwind ( n -- ) %epilogue-later RET ; diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index a3ab256ea1..3ad7d4f7b5 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -104,7 +104,7 @@ M: indirect extended? indirect-base extended? ; canonicalize-ESP ; : ( base index scale displacement -- indirect ) - indirect construct-boa dup canonicalize ; + indirect boa dup canonicalize ; : reg-code "register" word-prop 7 bitand ; @@ -189,7 +189,7 @@ UNION: operand register indirect ; { { [ dup register-128? ] [ drop operand-64? ] } { [ dup not ] [ drop operand-64? ] } - { [ t ] [ nip operand-64? ] } + [ nip operand-64? ] } cond and ; : rex.r diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 071535a01e..827a5c4e8d 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -160,7 +160,7 @@ PREDICATE: kernel-error < array { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } - { [ t ] [ second 0 15 between? ] } + [ second 0 15 between? ] } cond ; : kernel-errors @@ -215,7 +215,10 @@ M: check-method summary drop "Invalid parameters for create-method" ; M: no-tuple-class summary - drop "Invalid class for define-constructor" ; + drop "BOA constructors can only be defined for tuple classes" ; + +M: bad-superclass summary + drop "Tuple classes can only inherit from other tuple classes" ; M: no-cond summary drop "Fall-through in cond" ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index 28db6e1cbd..b0fe2a1157 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -1,5 +1,5 @@ USING: dlists dlists.private kernel tools.test random assocs -hashtables sequences namespaces sorting debugger io prettyprint +sets sequences namespaces sorting debugger io prettyprint math ; IN: dlists.tests @@ -79,7 +79,7 @@ IN: dlists.tests [ dlist-push-all ] keep [ dlist-delete-all ] keep dlist>array - ] 2keep seq-diff assert-same-elements + ] 2keep diff assert-same-elements ] unit-test [ ] [ diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 56134f3b54..e79907f11f 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -7,7 +7,7 @@ IN: dlists TUPLE: dlist front back length ; : ( -- obj ) - dlist construct-empty + dlist new 0 >>length ; : dlist-empty? ( dlist -- ? ) front>> not ; @@ -126,7 +126,7 @@ PRIVATE> { { [ over front>> over eq? ] [ drop pop-front* ] } { [ over back>> over eq? ] [ drop pop-back* ] } - { [ t ] [ unlink-node dec-length ] } + [ unlink-node dec-length ] } cond ; : delete-node-if* ( dlist quot -- obj/f ? ) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index aed4a64c6c..80a4f679c0 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -8,7 +8,7 @@ TUPLE: effect in out terminated? ; : ( in out -- effect ) dup { "*" } sequence= [ drop { } t ] [ f ] if - effect construct-boa ; + effect boa ; : effect-height ( effect -- n ) dup effect-out length swap effect-in length - ; @@ -20,7 +20,7 @@ TUPLE: effect in out terminated? ; { [ dup effect-terminated? ] [ f ] } { [ 2dup [ effect-in length ] bi@ > ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; GENERIC: (stack-picture) ( obj -- str ) diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index 33302572de..d25d447a46 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -24,7 +24,7 @@ M: float-array set-nth-unsafe M: float-array like drop dup float-array? [ >float-array ] unless ; -M: float-array new drop 0.0 ; +M: float-array new-sequence drop 0.0 ; M: float-array equal? over float-array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor index 2b023985a4..7f62f6f95c 100755 --- a/core/float-vectors/float-vectors.factor +++ b/core/float-vectors/float-vectors.factor @@ -7,7 +7,7 @@ IN: float-vectors vector ( float-array length -- float-vector ) - float-vector construct-boa ; inline + float-vector boa ; inline PRIVATE> @@ -22,7 +22,7 @@ M: float-vector like [ dup length float-array>vector ] [ >float-vector ] if ] unless ; -M: float-vector new +M: float-vector new-sequence drop [ 0.0 ] keep >fixnum float-array>vector ; M: float-vector equal? diff --git a/core/float-vectors/summary.txt b/core/float-vectors/summary.txt new file mode 100644 index 0000000000..c476f41a6e --- /dev/null +++ b/core/float-vectors/summary.txt @@ -0,0 +1 @@ +Growable float arrays diff --git a/core/float-vectors/tags.txt b/core/float-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/float-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 5cc0442464..920690e9d8 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -10,7 +10,7 @@ IN: generator.fixup TUPLE: frame-required n ; -: frame-required ( n -- ) \ frame-required construct-boa , ; +: frame-required ( n -- ) \ frame-required boa , ; : stack-frame-size ( code -- n ) no-stack-frame [ @@ -25,7 +25,7 @@ GENERIC: fixup* ( frame-size obj -- frame-size ) TUPLE: label offset ; -: