diff --git a/documentation/library-reference/source/dylan/index.rst b/documentation/library-reference/source/dylan/index.rst index d0555af05c..f22ce52524 100644 --- a/documentation/library-reference/source/dylan/index.rst +++ b/documentation/library-reference/source/dylan/index.rst @@ -371,3 +371,69 @@ a Table-extensions module, which you can read about in It returns a hash ID (an integer) and the result of merging the initial state with the associated hash state for the object, computed in some implementation-dependent manner. + +Limited Collections +------------------- + +To improve type safety of limited collections, Open Dylan implements an +extension to the :drm:`make` and :drm:`limited` functions. Normally, when +calling :drm:`make` on a collection that supports the ``fill:`` init-keyword, +that keyword defaults to ``#f``. This value can be inappropriate for a limited +collection. The :drm:`limited` function in Open Dylan accepts a +``default-fill:`` keyword argument which replaces the default of ``#f`` with a +user-specified value; this value is used by :drm:`make` and :drm:`size-setter` +when initializing or adding elements to those collections. + +Open Dylan also implements the :func:`element-type` and +:func:`element-type-fill` functions to further improve type safety. + +.. function:: limited + + Open Dylan implements the following altered signatures. + + :signature: limited singleton() #key *of* *size* *dimensions* *default-fill* => *type* + :signature: limited singleton() #key *of* *size* *default-fill* => *type* + :signature: limited singleton() #key *of* *size* *default-fill* => *type* + :signature: limited singleton() #key *of* *default-fill* => *type* + :signature: limited singleton() #key *of* *default-fill* => *type* + :signature: limited singleton() #key *of* *size* *default-fill* => *type* + + :param #key default-fill: + The default value of the ``fill:`` keyword argument to the :drm:`make` + function, replacing ``#f``. Optional. If not supplied, the default + value for the ``default-fill:`` argument and thus for the ``fill:`` + argument to :drm:`make` is ``#f`` (or ``' '`` for strings). + + :example: + + .. code-block:: dylan + + define constant + = limited(, of: , default-fill: 42); + let some-answers = make(, size: 3); + // #[ 42, 42, 42 ] + +.. generic-function:: element-type + :open: + + Returns the element type of a collection. + + :signature: element-type *collection* => *type* + + :param collection: An instance of :drm:``. + :value type: The permitted element type of the collection. + +.. generic-function:: element-type-fill + :open: + + Returns a valid object that may be used for new elements of a collection. + + :signature: element-type-fill *collection* => *object* + + :param collection: An instance of :drm:`` that supports the + ``fill:`` init-keyword. + :value object: An object. + + :discussion: For limited collections, this object will be the defaulted or + supplied ``default-fill:`` argument to the :func:`limited` + function. diff --git a/documentation/release-notes/source/2014.1.rst b/documentation/release-notes/source/2014.1.rst index a9a11f7907..bb2387d8d1 100644 --- a/documentation/release-notes/source/2014.1.rst +++ b/documentation/release-notes/source/2014.1.rst @@ -84,6 +84,26 @@ Common Dylan * The function ``integer-to-string`` is now faster. +Dylan +===== + +Open Dylan now implements +`DEP-0007 (Type-Safe Limited Collections) `_. +This adds a ``default-fill:`` argument to ``limited``, a corresponding +``element-type-fill`` generic function, and an ``element-type`` generic +function applicable to all collections. With this, limited collections will now +be easier and safer to use—with one caveat: + +As described in the DEP-0007 document, Open Dylan had previously ensured that +some numeric limited collection types would automatically be filled with ``0`` +when instantiated *with* a non-zero size but *without* a ``fill:`` init-keyword. +This is no longer the case. Code that relied on this behavior must be updated +to provide valid ``fill:`` or ``default-fill:`` values. + +``element`` will no longer signal a type error when it returns its ``default:`` +value and that value does not match the element type of a limited collection. + + dylan-direct-c-ffi ================== diff --git a/sources/common-dylan/byte-vector.dylan b/sources/common-dylan/byte-vector.dylan index 2d40209d13..3514c8d835 100644 --- a/sources/common-dylan/byte-vector.dylan +++ b/sources/common-dylan/byte-vector.dylan @@ -10,7 +10,7 @@ License: See License.txt in this distribution for details. ///// BYTE-VECTOR ///// -define constant = limited(, of: ); +define constant = limited(, of: , default-fill: as(, 0)); /// Fast byte vector copying diff --git a/sources/common-dylan/format.dylan b/sources/common-dylan/format.dylan index c1bc1effd5..85469bb6ab 100644 --- a/sources/common-dylan/format.dylan +++ b/sources/common-dylan/format.dylan @@ -10,7 +10,8 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND /// String buffers //---*** Oh for a stretchy string... -define constant = limited(, of: ); +define constant = limited(, of: , + default-fill: as(, ' ')); //---*** Is there a more efficient way to do this? define function print-string diff --git a/sources/dfmc/modeling/limited-collections.dylan b/sources/dfmc/modeling/limited-collections.dylan index f31a00d7b5..5fc2d401fd 100644 --- a/sources/dfmc/modeling/limited-collections.dylan +++ b/sources/dfmc/modeling/limited-collections.dylan @@ -15,6 +15,29 @@ define class () required-init-keyword: limited-integer-mappings:; end class; +define class () + // #f is don't care + constant slot mapping-element-type :: false-or(type-union(, )), + required-init-keyword: element-type:; + constant slot mapping-consider-fill-value? :: = #f, + init-keyword: consider-fill-value?:; + constant slot mapping-fill-value :: = #f, + init-keyword: fill-value:; + constant slot mapping-concrete-class :: , + required-init-keyword: concrete-class:; +end class; + +define method make + (class == , #rest all-keys, #key) + => (item :: ) + let keywords = choose-by(even?, range(), all-keys); + if (member?(#"fill-value", keywords)) + apply(next-method, class, consider-fill-value?:, #t, all-keys) + else + next-method(); + end if +end make; + define constant $limited-element-type-mappings = make(); @@ -23,6 +46,19 @@ define method install-limited-element-type-mappings add!($limited-element-type-mappings, pair(collection, mappings)); end method; +// Mappings should be listed in order, from best match to worst match. This matters +// for matching the default-fill; matching the tighter limited integer type; and for +// matching the fallback class. The lookup function will return the first suitable +// match. +// +// In the mappings later in this file, each element type entry has a line with +// a fill: option, followed by one without, but both returning the same concrete +// class. The difference between them is that when the user calls limited() with +// a matching default-fill: argument, the first line matches and the limited() +// function returns the concrete class directly; but if the user uses a different +// default-fill: argument, the second line matches and limited() returns a +// limited type specification that is not the concrete class itself nor even +// a at all. define macro limited-element-type-mappings-definer { define limited-element-type-mappings (?collection:name) ?mappings:* @@ -49,18 +85,40 @@ define macro limited-element-type-mappings-aux-definer { otherwise => ?concrete-class:name; ... } => { ... } + { any, + fill: ?fill:expression + => ?concrete-class:name; ... } + => { make(, + element-type: #f, fill-value: ?fill, + concrete-class: ?#"concrete-class"), ... } + { ?element-type:name, + fill: ?fill:expression + => ?concrete-class:name; ... } + => { make(, + element-type: ?#"element-type", fill-value: ?fill, + concrete-class: ?#"concrete-class"), ... } { ?element-type:name => ?concrete-class:name; ... } - => { pair(?#"element-type", ?#"concrete-class"), ... } + => { make(, + element-type: ?#"element-type", + concrete-class: ?#"concrete-class"), ... } { ?anything:* => ?concrete-class:name; ... } => { ... } limited-integer-mappings: { } => { } + { limited(, min: ?min:expression, max: ?max:expression), + fill: ?fill:expression + => ?concrete-class:name; ... } + => { make(, + element-type: pair(?min, ?max), fill-value: ?fill, + concrete-class: ?#"concrete-class"), ... } { limited(, min: ?min:expression, max: ?max:expression) => ?concrete-class:name; ... } - => { pair(pair(?min, ?max), ?#"concrete-class"), ... } + => { make(, + element-type: pair(?min, ?max), + concrete-class: ?#"concrete-class"), ... } { ?anything:* => ?concrete-class:name; ... } => { ... } @@ -76,28 +134,60 @@ define macro limited-element-type-mappings-aux-definer end macro; define method lookup-limited-collection-concrete-class - (element-type :: <&type>, mappings :: ) - => (concrete-class :: <&class>, default :: <&class>) + (element-type :: <&type>, element-type-fill, mappings :: ) + => (concrete-class :: <&class>, includes-element-type? :: , includes-default-fill? :: ) let default = dylan-value(limited-element-type-mapping-default(mappings)); block (return) if (instance?(element-type, <&limited-integer>)) - for (limited-integer-mapping in limited-limited-integer-element-type-mappings(mappings)) - let limited-integer-min-max - = head(limited-integer-mapping); - let limited-integer - = ^limited-integer(min: head(limited-integer-min-max), max: tail(limited-integer-min-max)); - if (^subtype?(element-type, limited-integer)) - return(dylan-value(tail(limited-integer-mapping)), default); + for (limited-integer-mapping :: + in limited-limited-integer-element-type-mappings(mappings)) + let match-element-type? = true?(limited-integer-mapping.mapping-element-type); + let match-fill-value? = limited-integer-mapping.mapping-consider-fill-value?; + let matching-element-type? + = if (match-element-type?) + let limited-integer-min-max :: + = limited-integer-mapping.mapping-element-type; + let limited-integer + = ^limited-integer(min: head(limited-integer-min-max), max: tail(limited-integer-min-max)); + ^subtype?(element-type, limited-integer) + else + #t + end if; + let matching-default-fill? + = if (match-fill-value?) + element-type-fill == limited-integer-mapping.mapping-fill-value + else + #t + end if; + if (matching-element-type? & matching-default-fill?) + return(dylan-value(limited-integer-mapping.mapping-concrete-class), + match-element-type?, match-fill-value?) end if end for; else - for (class-mapping in limited-class-element-type-mappings(mappings)) - if (element-type == dylan-value(head(class-mapping))) - return(dylan-value(tail(class-mapping)), default); + for (class-mapping :: + in limited-class-element-type-mappings(mappings)) + let match-element-type? = true?(class-mapping.mapping-element-type); + let match-fill-value? = class-mapping.mapping-consider-fill-value?; + let matching-element-type? + = if (match-element-type?) + element-type == dylan-value(class-mapping.mapping-element-type) + else + #t + end if; + let matching-default-fill? + = if (match-fill-value?) + element-type-fill == class-mapping.mapping-fill-value + else + #t + end if; + if (matching-element-type? & matching-default-fill?) + return(dylan-value(class-mapping.mapping-concrete-class), + match-element-type?, match-fill-value?); end if end for; end if; - values(default, default) + values(default, #f, #f) end block; end method; @@ -105,15 +195,25 @@ define method lookup-limited-collection-element-type (concrete-class :: <&class>, mappings :: ) => (element-type :: false-or(<&type>)) block (return) - for (class-mapping in limited-class-element-type-mappings(mappings)) - if (concrete-class == dylan-value(tail(class-mapping))) - return(dylan-value(head(class-mapping))); + for (class-mapping :: + in limited-class-element-type-mappings(mappings)) + if (concrete-class == dylan-value(class-mapping.mapping-concrete-class)) + if (class-mapping.mapping-element-type) + return(dylan-value(class-mapping.mapping-element-type)); + else + return(#f) + end if end if end for; - for (limited-integer-mapping in limited-limited-integer-element-type-mappings(mappings)) - let limited-integer = head(limited-integer-mapping); - if (concrete-class == dylan-value(tail(limited-integer-mapping))) - return(^limited-integer(min: head(limited-integer), max: tail(limited-integer))) + for (limited-integer-mapping :: + in limited-limited-integer-element-type-mappings(mappings)) + if (concrete-class == dylan-value(limited-integer-mapping.mapping-concrete-class)) + if (limited-integer-mapping.mapping-element-type) + let limited-integer = limited-integer-mapping.mapping-element-type; + return(^limited-integer(min: head(limited-integer), max: tail(limited-integer))) + else + return(#f) + end if end if end for; if (concrete-class == dylan-value(limited-element-type-mapping-default(mappings))) @@ -139,19 +239,31 @@ define method lookup-any-limited-collection-element-type end method; define limited-element-type-mappings () - => ; - => ; - otherwise => ; + , fill: as(, ' ') + => ; + + => ; + + , fill: as(, ' ') + => ; + + => ; + + any, fill: as(, ' ') + => ; + otherwise + => ; end limited-element-type-mappings; -define method select-limited-string (of, size) - let concrete-class - = lookup-limited-collection-concrete-class(of, $-mappings); - if (size) +define method select-limited-string (of, default-fill, size) + let (concrete-class, includes-element-type?, includes-default-fill?) + = lookup-limited-collection-concrete-class(of, default-fill, $-mappings); + if (size | ~includes-element-type? | ~includes-default-fill?) ^make(<&limited-vector-type>, class: dylan-value(#""), concrete-class: concrete-class, element-type: of, + default-fill: default-fill, size: size); else concrete-class @@ -159,32 +271,53 @@ define method select-limited-string (of, size) end method; define limited-element-type-mappings () - - => ; - - => ; + , fill: as(, 0) + => ; => ; + + , fill: as(, 0.0) + => ; => ; + + , fill: as(, 0.0) + => ; => ; + + limited(, min: 0, max: 255), fill: 0 + => ; limited(, min: 0, max: 255) => ; + limited(, min: 0, max: 65535), fill: 0 + => ; limited(, min: 0, max: 65535) => ; + + , fill: 0 + => ; + + => ; + + , fill: #f + => ; + + any, fill: #f + => ; otherwise => ; end limited-element-type-mappings; -define method select-limited-vector (of, size) - let (concrete-class, default-concrete-class) - = lookup-limited-collection-concrete-class(of, $-mappings); - if (size | concrete-class == default-concrete-class) +define method select-limited-vector (of, default-fill, size) + let (concrete-class, includes-element-type?, includes-default-fill?) + = lookup-limited-collection-concrete-class(of, default-fill, $-mappings); + if (size | ~includes-element-type? | ~includes-default-fill?) ^make(<&limited-vector-type>, class: dylan-value(#""), concrete-class: concrete-class, element-type: of, + default-fill: default-fill, size: size); else concrete-class @@ -192,37 +325,59 @@ define method select-limited-vector (of, size) end method; define limited-element-type-mappings () - - => ; - - => ; + , fill: as(, 0) + => ; => ; + + , fill: as(, 0.0) + => ; => ; + + , fill: as(, 0.0) + => ; => ; + + limited(, min: 0, max: 255), fill: 0 + => ; limited(, min: 0, max: 255) => ; + + limited(, min: 0, max: 65535), fill: 0 + => ; limited(, min: 0, max: 65535) => ; + + , fill: 0 + => ; + + => ; + + , fill: #f + => ; + + any, fill: #f + => ; otherwise => ; end limited-element-type-mappings; -define method select-limited-array (of, sz, dimensions) +define method select-limited-array (of, default-fill, sz, dimensions) if (sz) - select-limited-vector(of, sz) + select-limited-vector(of, default-fill, sz) elseif (dimensions & size(dimensions) = 1) - select-limited-vector(of, first(dimensions)) + select-limited-vector(of, default-fill, first(dimensions)) else - let (concrete-class, default-concrete-class) - = lookup-limited-collection-concrete-class(of, $-mappings); - if (dimensions | concrete-class == default-concrete-class) + let (concrete-class, includes-element-type?, includes-default-fill?) + = lookup-limited-collection-concrete-class(of, default-fill, $-mappings); + if (size | ~includes-element-type? | ~includes-default-fill?) ^make(<&limited-array-type>, class: dylan-value(#""), concrete-class: concrete-class, element-type: of, + default-fill: default-fill, dimensions: dimensions); else concrete-class @@ -231,23 +386,33 @@ define method select-limited-array (of, sz, dimensions) end method; define limited-element-type-mappings () - - => ; + , fill: as(, ' ') + => ; => ; + + limited(, min: 0, max: 255), fill: 0 + => ; limited(, min: 0, max: 255) => ; + + , fill: #f + => ; + + any, fill: #f + => ; otherwise => ; end limited-element-type-mappings; -define method select-limited-stretchy-vector (of) - let (concrete-class, default-concrete-class) - = lookup-limited-collection-concrete-class(of, $-mappings); - if (concrete-class == default-concrete-class) +define method select-limited-stretchy-vector (of, default-fill) + let (concrete-class, includes-element-type?, includes-default-fill?) + = lookup-limited-collection-concrete-class(of, default-fill, $-mappings); + if (~includes-element-type? | ~includes-default-fill?) ^make(<&limited-stretchy-vector-type>, class: dylan-value(#""), concrete-class: concrete-class, + default-fill: default-fill, element-type: of); else concrete-class @@ -262,9 +427,9 @@ define limited-element-type-mappings () end limited-element-type-mappings; define method select-limited-table (of, size) - let (concrete-class, default-concrete-class) - = lookup-limited-collection-concrete-class(of, $
-mappings); - if (size | concrete-class == default-concrete-class) + let (concrete-class, includes-element-type?, includes-default-fill?) + = lookup-limited-collection-concrete-class(of, #f, $
-mappings); + if (size | ~includes-element-type?) ^make(<&limited-table-type>, class: dylan-value(#"
"), concrete-class: dylan-value(#""), @@ -283,9 +448,9 @@ define limited-element-type-mappings () end limited-element-type-mappings; define method select-limited-set (of, size) - let (concrete-class, default-concrete-class) - = lookup-limited-collection-concrete-class(of, $-mappings); - if (size | concrete-class == default-concrete-class) + let (concrete-class, includes-element-type?, includes-default-fill?) + = lookup-limited-collection-concrete-class(of, #f, $-mappings); + if (size | ~includes-element-type?) ^make(<&limited-set-type>, class: dylan-value(#""), concrete-class: concrete-class, @@ -297,19 +462,20 @@ define method select-limited-set (of, size) end method; define limited-element-type-mappings () - + , fill: #f => ; otherwise => ; end limited-element-type-mappings; -define method select-limited-deque (of) - let (concrete-class, default-concrete-class) - = lookup-limited-collection-concrete-class(of, $-mappings); - if (size | concrete-class == default-concrete-class) +define method select-limited-deque (of, default-fill) + let (concrete-class, includes-element-type?, includes-default-fill?) + = lookup-limited-collection-concrete-class(of, default-fill, $-mappings); + if (size | ~includes-element-type? | ~includes-default-fill?) ^make(<&limited-deque-type>, class: dylan-value(#""), concrete-class: concrete-class, + default-fill: default-fill, element-type: of); else concrete-class @@ -317,65 +483,62 @@ define method select-limited-deque (of) end method; define method ^limited-collection - (class :: <&class>, #rest all-keys, #key of, size, dimensions, #all-keys) - if (of) - // PARALLELS RUNTIME METHODS ON LIMITED - select (class) - dylan-value(#"") // TODO: NOT YET IMPLEMENTED - => class; - dylan-value(#"") - => select-limited-string(of, size); - dylan-value(#"") - => select-limited-deque(of); - dylan-value(#"") - => select-limited-stretchy-vector(of); - dylan-value(#""), dylan-value(#"") - => select-limited-vector(of, size); - dylan-value(#"") - => select-limited-array(of, size, dimensions); - dylan-value(#"") - => select-limited-set(of, size); - dylan-value(#"
"), dylan-value(#"") - => select-limited-table(of, size); - // UNINSTANTIATEABLE LIMITED COLLECTION TYPES - dylan-value(#"") - => ^make(<&limited-collection-type>, - class: class, - element-type: of, - size: size); - dylan-value(#"") - => ^make(<&limited-explicit-key-collection-type>, - class: class, - element-type: of, - size: size); - dylan-value(#"") - => ^make(<&limited-mutable-collection-type>, - class: class, - element-type: of, - size: size); - dylan-value(#"") - => ^make(<&limited-stretchy-collection-type>, - class: class, - element-type: of); - dylan-value(#"") - => ^make(<&limited-mutable-explicit-key-collection-type>, - class: class, - element-type: of, - size: size); - dylan-value(#"") - => ^make(<&limited-sequence-type>, - class: class, - element-type: of, - size: size); - dylan-value(#"") - => ^make(<&limited-mutable-sequence-type>, - class: class, - element-type: of, - size: size); - otherwise - => #f; - end select - else - class - end if; + (class :: <&class>, #rest all-keys, + #key of, default-fill, size, dimensions, #all-keys) + // PARALLELS RUNTIME METHODS ON LIMITED + select (class) + dylan-value(#"") // TODO: NOT YET IMPLEMENTED + => class; + dylan-value(#"") + => select-limited-string(of, default-fill, size); + dylan-value(#"") + => select-limited-deque(of, default-fill); + dylan-value(#"") + => select-limited-stretchy-vector(of, default-fill); + dylan-value(#""), dylan-value(#"") + => select-limited-vector(of, default-fill, size); + dylan-value(#"") + => select-limited-array(of, default-fill, size, dimensions); + dylan-value(#"") + => select-limited-set(of, size); + dylan-value(#"
"), dylan-value(#"") + => select-limited-table(of, size); + // UNINSTANTIATEABLE LIMITED COLLECTION TYPES + dylan-value(#"") + => ^make(<&limited-collection-type>, + class: class, + element-type: of, + size: size); + dylan-value(#"") + => ^make(<&limited-explicit-key-collection-type>, + class: class, + element-type: of, + size: size); + dylan-value(#"") + => ^make(<&limited-mutable-collection-type>, + class: class, + element-type: of, + size: size); + dylan-value(#"") + => ^make(<&limited-stretchy-collection-type>, + class: class, + element-type: of); + dylan-value(#"") + => ^make(<&limited-mutable-explicit-key-collection-type>, + class: class, + element-type: of, + size: size); + dylan-value(#"") + => ^make(<&limited-sequence-type>, + class: class, + element-type: of, + size: size); + dylan-value(#"") + => ^make(<&limited-mutable-sequence-type>, + class: class, + element-type: of, + size: size); + otherwise + => #f; + end select end method; diff --git a/sources/dfmc/modeling/modeling-library.dylan b/sources/dfmc/modeling/modeling-library.dylan index f3eb42c3ea..89345102a2 100644 --- a/sources/dfmc/modeling/modeling-library.dylan +++ b/sources/dfmc/modeling/modeling-library.dylan @@ -413,6 +413,7 @@ define module-with-models dfmc-modeling &getter limited-collection-class, &getter limited-collection-concrete-class, &getter limited-collection-element-type, + &getter limited-collection-element-type-fill, &getter limited-collection-size, &getter limited-collection-dimensions, lookup-any-limited-collection-element-type, @@ -766,7 +767,10 @@ define module-with-models dfmc-modeling <&mutable-object-with-elements>, // <&collection>, <&limited-collection>, + <&limited-element-type-collection>, &getter element-type, + <&limited-fillable-collection>, + &slot element-type-fill, // <&sequence>, // <&mutable-collection>, // <&mutable-sequence>, diff --git a/sources/dfmc/modeling/namespaces.dylan b/sources/dfmc/modeling/namespaces.dylan index 278d61d756..70a2d03d93 100644 --- a/sources/dfmc/modeling/namespaces.dylan +++ b/sources/dfmc/modeling/namespaces.dylan @@ -731,8 +731,7 @@ define &module dylan-extensions ; create - , - element-type; + ; create , @@ -741,6 +740,8 @@ define &module dylan-extensions limited-collection-element-type, limited-collection-size, limited-collection-dimensions, + , + limited-collection-element-type-fill, , , , @@ -791,7 +792,6 @@ define &module dylan-extensions stretchy-representation-type, stretchy-vector-element, stretchy-vector-element-setter, - collection-fill, limited-stretchy-vector, limited-array, limited-vector, @@ -1337,6 +1337,7 @@ end &module; /// Last checked: 19th Jan 96, against DRM Draft of September 29, 1995. /// Modified: 27 Mar 97 to add function-definer, an approved new feature, by GMP. /// Modified: 8 Apr 97 to rename => , by GMP. +/// Modified: 10 Aug 13 to add element-type and element-type-fill for DEP-0007, by DJV. define &module dylan @@ -1480,6 +1481,7 @@ define &module dylan , , + element-type, size, size-setter, empty?, @@ -1499,6 +1501,7 @@ define &module dylan , , + element-type-fill, add, add!, add-new, diff --git a/sources/dfmc/modeling/objects.dylan b/sources/dfmc/modeling/objects.dylan index 511b95f987..b6c9c6a532 100644 --- a/sources/dfmc/modeling/objects.dylan +++ b/sources/dfmc/modeling/objects.dylan @@ -291,12 +291,6 @@ define sealed concrete &class () inherited &slot head, init-value: #(), init-keyword: head:; end &class ; -define open abstract primary &class () - constant &slot element-type :: , - init-keyword: element-type:, - init-value: ; -end &class; - define open abstract &class () end; define open abstract &class () end; @@ -337,6 +331,48 @@ end &class ; // HACK: SHOULDN'T GENERATE THESE IN THE FIRST PLACE ignore(^string-element-values); ignore(^string-element-setter); +// This is a marker class for all concrete limited collection classes. +define open abstract primary &class () +end &class; + +// This is a mixin class for concrete limited classes with user-specified +// element types. Concrete limited classes with predefined types such as +// do not need it. +define abstract primary &class + () + constant &slot element-type :: , + init-keyword: element-type:, + init-value: ; +end &class; + +define open generic ^element-type (coll :: <&collection>) => (type :: <&type>); +define sealed domain ^element-type (<&limited-collection>); + +define method ^element-type (coll :: <&collection>) => (type :: <&type>) + dylan-value(#"") +end method; + +// DEP-0007: This is a mixin class for all fillable concrete limited classes. +// Each instance of a limited collection must track its default fill value. +// +// The element-type-fill slot can't actually be constant because the make +// function needs to be able to set it explicitly after allocating the object. +// system-allocate-repeated-instance can only populate all slots with a single +// value, and that value was chosen to be element-type. +define abstract &class + () + /*constant*/ &slot element-type-fill :: , + init-keyword: element-type-fill:, + init-value: #f; +end &class; + +define open generic ^element-type-fill (coll :: <&collection>) => (object); +define sealed domain ^element-type-fill (<&limited-collection>); + +define method ^element-type-fill (coll :: <&collection>) => (object); + #f +end method; + // Built-in collection functions define generic ^empty? (object :: ) => (result :: ); diff --git a/sources/dfmc/modeling/types.dylan b/sources/dfmc/modeling/types.dylan index cecdc21af8..845dabbea3 100644 --- a/sources/dfmc/modeling/types.dylan +++ b/sources/dfmc/modeling/types.dylan @@ -101,7 +101,7 @@ end method; define abstract &class () end &class; -define &class () +define primary &class () constant &slot limited-collection-class :: , required-init-keyword: class:; constant &slot limited-collection-element-type :: , @@ -117,6 +117,14 @@ define &class () init-keyword: dimensions:; end &class; +// DEP-0007: This mixin applies to all collection classes for which the +// fill: init-keyword is valid, i.e. all subclasses of +// except for , , and . +define abstract &class () + constant &slot limited-collection-element-type-fill :: , + required-init-keyword: default-fill:; +end &class; + define &class () end &class; @@ -137,13 +145,15 @@ define &class (, ) end &class; -define &class () +define &class + (, ) end &class; define &class () end &class; -define &class () +define &class + (, ) end &class; define &class @@ -151,7 +161,8 @@ define &class end &class; define &class - (, ) + (, , + ) end &class; define &class () @@ -255,6 +266,8 @@ define method ^known-disjoint? (t1 :: <&limited-collection-type>, t2 :: <&class> ^known-disjoint?(t2, t1) end method ^known-disjoint?; +//// Limited types. + define &override-function ^limited (type :: <&type>, #rest keys) => (type :: <&type>) select (type) diff --git a/sources/dfmc/typist/typist-types.dylan b/sources/dfmc/typist/typist-types.dylan index 4c58e938ab..3abb4fd5d1 100644 --- a/sources/dfmc/typist/typist-types.dylan +++ b/sources/dfmc/typist/typist-types.dylan @@ -30,8 +30,9 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND /// - Limited Instance: singleton(x) denotes anything == to x. /// /// - Limited Collection: some collections support of: to limit the type of -/// their elements, size: to limit their overall size, and dimensions: if -/// they happen to be arrays. +/// their elements, default-fill: to provide a valid default fill value for +/// size-setter or make, size: to limit their overall size, and dimensions: +/// if they happen to be arrays. /// /// More details: /// , , , @@ -41,21 +42,21 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND ///
, support of:, size: and return an instantiable /// type that supports a size: initialization. /// -/// supports of:, size:, dimensions: and returns an instantiable -/// type that supports dimensions: and fill: initializations. Note -/// constraint between fill: (default #f) and of:. +/// supports of:, default-fill:, size:, dimensions: and returns an +/// instantiable type that supports dimensions: and fill: +/// initializations. Note constraint between fill: and of:. /// -/// , support of:, size: and return an -/// instantiable type which takes size: and fill: keys. Note -/// constraint between fill: (default #f) and of:. +/// , support of:, default-fill:, size: and +/// return an instantiable type which takes size: and fill: keys. Note +/// constraint between fill: and of:. /// -/// , support of: and return an +/// , support of: and default-fill: and return an /// instantiable type which takes size: and fill: keys. Note -/// constraint between fill: (default #f) and of:. +/// constraint between fill: and of:. /// -/// supports of:, size: and returns an instantiable type -/// supporting size: and fill:. of: must be subtype of character. -/// Default for fill: is ' '. +/// supports of:, default-fill:, size: and returns an +/// instantiable type supporting size: and fill:. of: must be subtype +/// of character. /// /// supports of: (subtype of ). Result takes from:, to:, /// below:, above:, by:, size:. diff --git a/sources/dylan/accumulator.dylan b/sources/dylan/accumulator.dylan index 112129385f..3e89fe2e2f 100644 --- a/sources/dylan/accumulator.dylan +++ b/sources/dylan/accumulator.dylan @@ -233,12 +233,12 @@ define method convert-accumulator-as (type :: , acc :: ) => (result :: ); // actually :: type; if (size(acc) = 0) - let target = make(type, size: 0); + let target = make-sequence(type, size: 0); check-key-test-eq(target, acc); target else let target = - make(type, size: acc.acc-size, fill: acc.acc-buffer[acc.acc-index]); + make-sequence(type, size: acc.acc-size, fill: acc.acc-buffer[acc.acc-index]); check-key-test-eq(target, acc); with-fip-of target /* with-setter? */ for (e in acc, @@ -275,7 +275,7 @@ define method convert-accumulator-as let sz = size(acc); if (sz = 0) - let target = make(type, size: 0); + let target = make-sequence(type, size: 0); check-key-test-eq(target, acc); target else // Use a temp for fast random update and coerce when done diff --git a/sources/dylan/array.dylan b/sources/dylan/array.dylan index 7cc9e65f03..a5505fd040 100644 --- a/sources/dylan/array.dylan +++ b/sources/dylan/array.dylan @@ -8,6 +8,9 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND // BOOTED: define ... class ... end; +define constant + = type-union(subclass(), ); + //////////// // INTERFACE @@ -35,7 +38,7 @@ define open generic dimension (array :: , axis :: ) => (dim :: ); define open generic limited-array - (of :: , dimensions :: false-or()) + (of :: , default-fill :: , dimensions :: false-or()) => (type :: ); @@ -185,11 +188,10 @@ end method make; define method shallow-copy (array :: ) => (array :: ) let size = size(array); if (size = 0) - make(array.type-for-copy, dimensions: dimensions); + make(array.type-for-copy, dimensions: array.dimensions); else - let dimensions :: = array.dimensions; let new-array :: = - make(array.type-for-copy, dimensions: dimensions, fill: array[0]); + make(array.type-for-copy, dimensions: array.dimensions, fill: array[0]); for (key :: from 0 below size) new-array[key] := array[key]; diff --git a/sources/dylan/boot.dylan b/sources/dylan/boot.dylan index a3e4bf178e..514e98e8a2 100644 --- a/sources/dylan/boot.dylan +++ b/sources/dylan/boot.dylan @@ -1213,6 +1213,7 @@ define shared-symbols %shared-dylan-symbols #"domain-types", #"each-subclass", #"element-type", + #"element-type-fill", #"end", #"failure", #"fill", diff --git a/sources/dylan/collection.dylan b/sources/dylan/collection.dylan index 7d0745cf20..38437703e8 100644 --- a/sources/dylan/collection.dylan +++ b/sources/dylan/collection.dylan @@ -56,9 +56,13 @@ define constant define constant = type-union(subclass(), ); +// This generic is defined on because the DRM says so and the test suite +// expects it to be so. However, the only implemented method is on +// and this generic is sealed, so there should not be +// a dispatch hit. define sealed generic map-as - (type :: , fn :: , - collection :: , #rest more-collections :: ) + (type :: , fn :: , collection :: , + #rest more-collections :: ) => (new-collection :: ); define sealed generic map-into @@ -281,11 +285,11 @@ define method map-as-one => (new-collection :: ); // actually :: type let collection-size = collection.size; if (collection-size = 0) - make(type, size: 0) + make-sequence(type, shaped-like: collection) else let result = - make(type, dimensions: collection.dimensions, - fill: function(collection.first)); + make-sequence(type, shaped-like: collection, + fill: function(collection.first)); without-bounds-checks for (i :: from 1 below collection-size) result[i] := function(collection[i]) @@ -301,11 +305,11 @@ define method map-as-one => (new-collection :: ); // actually :: type let collection-size = collection.size; if (collection-size = 0) - make(type, size: 0) + make-sequence(type, shaped-like: collection) else let result = - make(type, size: collection.size, - fill: function(collection.first)); + make-sequence(type, shaped-like: collection, + fill: function(collection.first)); without-bounds-checks for (i :: from 1 below collection-size) result[i] := function(collection[i]) @@ -1095,16 +1099,24 @@ define constant = ; // KLUDGE FOR LIMITED COLLECTIONSXS /// define open abstract primary class ... end; -// The element type for limited collections. -define open generic element-type (t :: ) - => type :: ; +// User-defined collections can define their own element-type and element-type-fill +// on open collection classes. But since users cannot define their own limited +// collections, we can seal over that domain. +define open generic element-type (coll :: ) => (type :: ); define sealed domain element-type (); -define inline method element-type (t :: ) => (type == ) +define inline method element-type (coll :: ) => (type :: ) end method; +define open generic element-type-fill (coll :: ) => (object :: ); +define sealed domain element-type-fill (); + +define inline method element-type-fill (coll :: ) => (object) + #f +end method; + // This function helps compute an upper bound on the maximum // integer key in a collection. diff --git a/sources/dylan/deque.dylan b/sources/dylan/deque.dylan index 808f08c856..664efe21e9 100644 --- a/sources/dylan/deque.dylan +++ b/sources/dylan/deque.dylan @@ -107,40 +107,38 @@ end method reverse; // // -define class (, ) +define class + (, , ) slot representation :: , init-value: make(); end class ; +define sealed domain make (singleton()); -define sealed domain element-type (); /// /// LIMITED DEQUES /// define method limited-deque - (of :: ) => (type :: ) + (of :: , default-fill :: ) => (type :: ) make(, class: , element-type: of, + default-fill: default-fill, concrete-class: ); end method; -define method limited - (class == , #key of, #all-keys) => (type :: ) - limited-deque(of) -end method; - /// TODO: COULD BE EXPENSIVE UNLESS TYPES ARE CACHED define sealed inline method type-for-copy (x :: ) => (type :: ) let elt-type = element-type(x); - if (elt-type == ) + let elt-fill = element-type-fill(x); + if (elt-type == & elt-fill == #f) object-class(x) else - limited-deque(elt-type) + limited-deque(elt-type, elt-fill) end if end method type-for-copy; @@ -225,7 +223,8 @@ end method size; // define sealed inline method trusted-size-setter - (new-size :: , collection :: ) + (new-size :: , collection :: , + #key fill = collection.element-type-fill) => (new-size :: ) // TODO: write a faster version of this method. let difference = new-size - collection.size; @@ -235,8 +234,9 @@ define sealed inline method trusted-size-setter pop-last(collection) end; difference > 0 => + check-type(fill, collection.element-type); for (i :: from 0 below difference) - trusted-push-last(collection, #f) + trusted-push-last(collection, fill) end; end case; new-size @@ -246,11 +246,6 @@ define sealed method size-setter (new-size :: , collection :: (new-size :: ) // TODO: write a faster version of this method. check-nat(new-size); - let size = size(collection); - unless (new-size <= size) - // expected to fail when #f is incompatible with element-type - check-type(#f, element-type(collection)) - end unless; trusted-size(collection) := new-size; end method size-setter; @@ -280,7 +275,6 @@ define sealed method element if (unsupplied?(default)) element-range-error(collection, index) else - check-type(default, element-type(collection)); default end if else @@ -321,11 +315,12 @@ define sealed method element-setter if (index < 0) element-range-error(collection, index) end; if (index > rep-size-minus-1) if (collection.size = index) - trusted-size(collection) := index + 1; + trusted-size-setter(index + 1, collection, fill: new-value); + new-value else collection.size := index + 1; + collection[index] := new-value // Let's try again end if; - collection[index] := new-value // Let's try again else // Even if multiple threads are running, and rep-first-index and // rep-last-index are incorrect, they should be within the bounds of @@ -404,11 +399,13 @@ end method reverse!; // PRIVATE define method grow! (deque :: ) + let fill = deque.element-type-fill; + check-type(fill, deque.element-type); let old-rep = deque.representation; let old-rep-first-index = old-rep.first-index; let old-rep-last-index = old-rep.last-index; let old-rep-size = (old-rep-last-index - old-rep-first-index) + 1; - let new-rep = make(, size: old-rep-size * 2, fill: #f); + let new-rep = make(, size: old-rep-size * 2, fill: fill); new-rep.first-index := truncate/(old-rep-size, 2); for (src-index :: from old-rep-first-index to old-rep-last-index, @@ -631,7 +628,7 @@ define sealed method copy-sequence let rep-first-index = rep.first-index; let rep-last-index = rep.last-index; let deque-size = (rep-last-index - rep-first-index) + 1; - let target = make(, size: deque-size, element-type: element-type(source)); + let target = make(type-for-copy(source), size: deque-size); let target-rep = target.representation; for (from :: from rep-first-index to rep-last-index, to :: from target-rep.first-index to target-rep.last-index) @@ -663,9 +660,6 @@ define method concatenate-as-two end end; -define sealed domain make (singleton()); -define sealed domain element-type (); - define sealed method as (class == , v :: ) => (l :: ) let rep = v.representation; diff --git a/sources/dylan/extras.dylan b/sources/dylan/extras.dylan index 1bd70f2d11..71bc5f4e1e 100644 --- a/sources/dylan/extras.dylan +++ b/sources/dylan/extras.dylan @@ -9,3 +9,24 @@ define function as-object (x :: ) primitive-cast-raw-as-pointer (primitive-unwrap-machine-word(x)) end function; + +define function remove-keyword-arguments + (symbols/values :: , removals :: ) + => (new-symbols/values :: ) + let new-symbols/values = make(); + with-fip-of symbols/values + iterate check-and-copy (symbol-state = initial-state) + unless (finished-state?(symbols/values, symbol-state, limit)) + let symbol = current-element(symbols/values, symbol-state); + let value-state = next-state(symbols/values, symbol-state); + unless (member?(symbol, removals)) + let value = current-element(symbols/values, value-state); + add!(new-symbols/values, symbol); + add!(new-symbols/values, value); + end unless; + check-and-copy(next-state(symbols/values, value-state)) + end unless + end iterate + end with-fip-of; + new-symbols/values +end function; diff --git a/sources/dylan/limited-array.dylan b/sources/dylan/limited-array.dylan index 81d0c14579..dafb5add2b 100644 --- a/sources/dylan/limited-array.dylan +++ b/sources/dylan/limited-array.dylan @@ -5,34 +5,41 @@ Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc. License: See License.txt in this distribution for details. Warranty: Distributed WITHOUT WARRANTY OF ANY KIND -define limited-array (fill: 0); +define limited-array (fill: 0); -define limited-array-minus-selector () (fill: 0); -define limited-array-minus-selector () (fill: 0); +define limited-array-minus-selector + (, ) + (fill: as(, 0)); -define limited-array-minus-constructor (, ) - (fill: #f); +define limited-array-minus-selector + (, ) + (fill: as(, 0)); -define sealed domain element-type (); +define limited-array-minus-constructor + (, , ) + (fill: #f); define sealed method make (class == , - #key dimensions = unsupplied(), element-type, fill = #f) + #key dimensions = unsupplied(), element-type = , fill = #f, + element-type-fill: default-fill = #f) => (array :: ) let (dimensions, size) = compute-array-dimensions-and-size(dimensions); unless (size = 0) check-type(fill, element-type); end unless; next-method(class, - element-type: element-type, - dimensions: dimensions, - size: size, - fill: fill) + element-type: element-type, + element-type-fill: default-fill, + dimensions: dimensions, + size: size, + fill: fill) end method; define method concrete-limited-array-class - (of :: ) => (res :: ) - + (of :: , default-fill) + => (res :: , fully-specified? :: ) + values(, #f) end method; define sealed inline method element-setter @@ -48,20 +55,21 @@ end method element-setter; define sealed inline method type-for-copy (array :: ) => (type :: ) - limited-array(element-type(array), #f) + limited-array(element-type(array), element-type-fill(array), #f) end method type-for-copy; - /// REALLY NEED SUBTYPE SPECIALIZERS TO GET THIS TO HAPPEN IN MACRO define method concrete-limited-array-class - (of :: ) => (res :: ) + (of :: , default-fill) + => (res :: , fully-specified? :: ) + let fully-specified? = (default-fill = 0); select (of by subtype?) - => ; - => ; - otherwise => ; + => values(, fully-specified?); + => values(, fully-specified?); + otherwise => next-method(); end select; end method; define limited-array (fill: as(, 0)); -define limited-array (fill: 0.0); +define limited-array (fill: as(, 0.0)); define limited-array (fill: as(, 0.0)); diff --git a/sources/dylan/limited-stretchy-vector.dylan b/sources/dylan/limited-stretchy-vector.dylan index 67b948cb45..1157de5ed7 100644 --- a/sources/dylan/limited-stretchy-vector.dylan +++ b/sources/dylan/limited-stretchy-vector.dylan @@ -5,41 +5,63 @@ Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc. License: See License.txt in this distribution for details. Warranty: Distributed WITHOUT WARRANTY OF ANY KIND -define limited-stretchy-vector (fill: ' '); +// Assemble that works for the singletons. -define limited-stretchy-vector-minus-selector () (fill: 0); +define limited-stretchy-vector + + (fill: as(, ' ')); -define limited-stretchy-vector-minus-constructor - (, ) (fill: #f); + +// Assemble , but rely on the +// concrete-limited-stretchy-vector-class defined below that picks a limited +// stretchy vector type based on an informed examination of the user-supplied +// limited integer, rather than the concrete-limited-stretchy-vector-class +// defined by limited-stretchy-vector-definer which works only for the +// singletons. + +define limited-stretchy-vector-minus-selector + () + (fill: as(, 0)); + +/// REALLY NEED SUBTYPE SPECIALIZERS TO GET THIS TO HAPPEN IN MACRO +define method concrete-limited-stretchy-vector-class + (of :: , default-fill) + => (res :: , fully-specified? :: ) + let fully-specified? = (default-fill = 0); + select (of by subtype?) + => values(, fully-specified?); + // => ; + otherwise => next-method(); + end select; +end method; + + +// Assemble the general , using the functions +// below and the generic functions that allow +// for arbitrary element types. + +define limited-stretchy-vector-minus-constructor + (, ) + (fill: #f); define method initialize (vector :: , #key size :: = 0, capacity :: = size, - element-type :: , fill = #f) + element-type :: = , fill = #f, + element-type-fill: default-fill = #f) => () next-method(); unless (size = 0) check-type(fill, element-type); end unless; + vector.element-type-fill := default-fill; stretchy-initialize(vector, capacity, size, fill); - vector end method initialize; -define sealed domain element-type (); - -define method concrete-limited-stretchy-vector-class - (of :: ) => (res :: ) - -end method; - -/// REALLY NEED SUBTYPE SPECIALIZERS TO GET THIS TO HAPPEN IN MACRO define method concrete-limited-stretchy-vector-class - (of :: ) => (res :: ) - select (of by subtype?) - => ; - // => ; - otherwise => ; - end select; + (of :: , default-fill) + => (res :: , fully-specified? :: ) + values(, #f) end method; define sealed inline method element-setter @@ -50,7 +72,7 @@ define sealed inline method element-setter let collection-size = collection.size; if (index >= collection-size) if (index = collection-size) - collection.trusted-size := index + 1 + trusted-size-setter(index + 1, collection, fill: new-value) else collection.size := index + 1 end if @@ -65,5 +87,5 @@ end method element-setter; define sealed inline method type-for-copy (vector :: ) => (type :: ) - limited-stretchy-vector(element-type(vector)) + limited-stretchy-vector(element-type(vector), element-type-fill(vector)) end method type-for-copy; diff --git a/sources/dylan/limited-vector.dylan b/sources/dylan/limited-vector.dylan index 7ece42675e..39cbe4ce2f 100644 --- a/sources/dylan/limited-vector.dylan +++ b/sources/dylan/limited-vector.dylan @@ -5,27 +5,64 @@ Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc. License: See License.txt in this distribution for details. Warranty: Distributed WITHOUT WARRANTY OF ANY KIND -define limited-vector (fill: 0); +// Assemble that works for the singletons. + +define limited-vector (fill: as(, 0)); +define limited-vector (fill: as(, 0)); +define limited-vector (fill: as(, 0.0)); +define limited-vector (fill: as(, 0.0)); + + +// Assemble and , but rely on +// the concrete-limited-vector-class defined below that picks a limited vector +// type based on an informed examination of the user-supplied limited integer, +// rather than the concrete-limited-vector-class defined by +// limited-vector-definer which works only for the or +// singletons. + +define limited-vector-minus-selector + (, ) + (fill: as(, 0)); +define limited-vector-minus-selector + (, ) + (fill: as(, 0)); + +/// REALLY NEED SUBTYPE SPECIALIZERS TO GET THIS TO HAPPEN IN MACRO +define inline method concrete-limited-vector-class + (of :: , default-fill) + => (res :: , fully-specified? :: ) + let fully-specified? = (default-fill = 0); + select (of by subtype?) + => values(, fully-specified?); + => values(, fully-specified?); + otherwise => next-method(); + end select; +end method; -define limited-vector-minus-selector () (fill: 0); -define limited-vector-minus-selector () (fill: 0); -define limited-vector-minus-constructor (, ) - (fill: #f); +// Assemble the general , using the functions below +// and the generic functions that allow for arbitrary +// element types. + +define limited-vector-minus-constructor + (, , ) + (fill: #f); define method make (class == , - #key fill = #f, element-type :: , size :: = 0) + #key fill = #f, element-type :: = , size :: = 0, + element-type-fill: default-fill = #f) => (vector :: ) unless (size = 0) check-type(fill, element-type); end unless; - system-allocate-repeated-instance - (, , element-type, size, fill); + let instance :: + = system-allocate-repeated-instance + (, , element-type, size, fill); + instance.element-type-fill := default-fill; + instance end method; -define sealed domain element-type (); - define inline sealed method element-setter (new-value, vector :: , index :: ) => (object) check-type(new-value, element-type(vector)); @@ -40,25 +77,10 @@ end method element-setter; define inline method type-for-copy (vector :: ) => (type :: ) - limited-vector(element-type(vector), #f) + limited-vector(element-type(vector), element-type-fill(vector), #f) end method type-for-copy; -/// REALLY NEED SUBTYPE SPECIALIZERS TO GET THIS TO HAPPEN IN MACRO -define inline method concrete-limited-vector-class - (of :: ) => (res :: ) - select (of by subtype?) - => ; - => ; - otherwise => ; - end select; -end method; - -define limited-vector (fill: as(, 0)); -define limited-vector (fill: 0.0); -define limited-vector (fill: as(, 0.0)); - - // // SIMPLE-BYTE-VECTOR // diff --git a/sources/dylan/multidimensional-array.dylan b/sources/dylan/multidimensional-array.dylan index b9776f409b..17a49e03c2 100644 --- a/sources/dylan/multidimensional-array.dylan +++ b/sources/dylan/multidimensional-array.dylan @@ -15,9 +15,32 @@ define sealed inline method empty? (array :: ) => (b :: ) array.size = 0 end method empty?; -define constant = limited(, of: ); +define constant = limited(, of: , default-fill: 0); define constant $empty-dimensions = make(, size: 0); +define inline function compute-size-from-dimensions + (dimensions :: false-or()) + => (size :: false-or()) + dimensions + & if (dimensions.size = 0) + 0 + else + reduce(\*, 1, dimensions) + end if +end function; + +define function compute-array-dimensions-and-size + (dimensions) + => (dimensions :: , size :: ) + if (supplied?(dimensions)) + let canonical-dimensions = as(, dimensions); + values(canonical-dimensions, compute-size-from-dimensions(canonical-dimensions)); + else + error(make(, + format-string: "No dimensions in call to make()")); + end if; +end function; + define macro limited-array-minus-constructor-definer { define limited-array-minus-constructor "<" ## ?:name ## ">" (?superclasses:*) (#key ?fill:expression) } @@ -44,14 +67,13 @@ define macro limited-array-minus-constructor-definer define inline sealed method element (array :: "", index :: , - #key default = unsupplied()) => (object :: "<" ## ?name ## ">") + #key default = unsupplied()) => (object) if (element-range-check(index, size(array))) "row-major-" ## ?name ## "-array-element"(array, index) else if (unsupplied?(default)) element-range-error(array, index) else - check-type(default, element-type(array)); default end if end if @@ -85,29 +107,6 @@ define macro limited-array-minus-constructor-definer } end macro; -define inline function compute-size-from-dimensions - (dimensions :: false-or()) - => (size :: false-or()) - dimensions - & if (dimensions.size = 0) - 0 - else - reduce(\*, 1, dimensions) - end if -end function; - -define function compute-array-dimensions-and-size - (dimensions) - => (dimensions :: , size :: ) - if (supplied?(dimensions)) - let canonical-dimensions = as(, dimensions); - values(canonical-dimensions, compute-size-from-dimensions(canonical-dimensions)); - else - error(make(, - format-string: "No dimensions in call to make()")); - end if; -end function; - define macro limited-array-minus-selector-definer { define limited-array-minus-selector "<" ## ?:name ## ">" (?superclasses:*) (#key ?fill:expression) } @@ -118,7 +117,7 @@ define macro limited-array-minus-selector-definer (t :: "") => (type :: ) "<" ## ?name ## ">" end method; - + define sealed method element-setter (new-value :: "<" ## ?name ## ">", array :: "", index :: ) @@ -129,40 +128,57 @@ define macro limited-array-minus-selector-definer element-range-error(array, index) end if end method element-setter; - + define sealed method make - (class == "", #key dimensions = unsupplied(), fill) + (class == "", + #key dimensions = unsupplied(), fill = ?fill, + element-type-fill = ?fill) => (array :: "") let (dimensions, size) = compute-array-dimensions-and-size(dimensions); + unless (size = 0) + check-type(fill, "<" ## ?name ## ">") + end unless; ?=next-method(class, - dimensions: dimensions, - size: size, - fill: fill) - end method make } + dimensions: dimensions, + size: size, + element-type-fill: element-type-fill, + fill: fill) + end method make; + + define sealed inline method type-for-copy + (array :: "") + => (type :: ) + limited-array(element-type(array), element-type-fill(array), #f) + end method type-for-copy + } end macro; define macro limited-array-definer { define limited-array "<" ## ?:name ## ">" (#key ?fill:expression) } - => { define limited-array-minus-selector "<" ## ?name ## ">" () (fill: ?fill); + => { define limited-array-minus-selector "<" ## ?name ## ">" + (, ) (fill: ?fill); + define method concrete-limited-array-class - (of == "<" ## ?name ## ">") => (res :: ) - "" - end method } + (of == "<" ## ?name ## ">", default-fill) + => (res :: , fully-specified? :: ) + values("", default-fill = ?fill) + end method; + } end macro; define limited-array (fill: #f); define method limited-array - (of :: , dimensions :: false-or()) => (type :: ) - let concrete-class - = concrete-limited-vector-class(of); - let default-concrete-class - = ; - if (dimensions | concrete-class == default-concrete-class) + (of :: , default-fill :: , dimensions :: false-or()) + => (type :: ) + let (concrete-class, fully-specified?) + = concrete-limited-array-class(of, default-fill); + if (dimensions | ~fully-specified?) let size = compute-size-from-dimensions(dimensions); make(, class: , element-type: of, + default-fill: default-fill, concrete-class: concrete-class, size: size, dimensions: dimensions); diff --git a/sources/dylan/range.dylan b/sources/dylan/range.dylan index 35de5b3bc2..9aaf7c021e 100644 --- a/sources/dylan/range.dylan +++ b/sources/dylan/range.dylan @@ -104,6 +104,11 @@ end function; /// collection and sequence operations +// DEP-0007: element-type is a generic function on every collection. +define inline method element-type (range :: ) => (result == ) + +end method element-type; + define sealed inline method type-for-copy (range :: ) => (result == ) diff --git a/sources/dylan/sequence.dylan b/sources/dylan/sequence.dylan index c2e19feffb..68ec79cbc6 100644 --- a/sources/dylan/sequence.dylan +++ b/sources/dylan/sequence.dylan @@ -7,6 +7,86 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND // BOOTED: define ... class ... end; +define constant + = type-union(subclass(), ); + +define constant + = type-union(subclass(), ); + + +// Instances of must have the dimensions: init-keyword, but generic +// sequence methods won't know to provide that. This function creates an +// or other sequence with the appropriate init-keywords. +// +// The shaped-like: argument creates a sequence with the same dimensions or size +// as the given one. The size: argument creates a sequence with the given size; +// in the case of an , that sequence will be a . If both are +// given, the sequence will have the same dimensions/size as the shaped-like: +// argument so long as that doesn't conflict with the size: argument. + +define generic make-sequence + (type :: , + #key shaped-like :: false-or(), size :: false-or(), + #all-keys) + => (new-instance :: ); + +define inline method make-sequence + (type :: , #rest all-keys, + #key shaped-like: template :: false-or(), + size: desired-size :: false-or()) + => (new-instance :: ) + if (template) + if (~desired-size | desired-size = template.size) + apply(make, type, size: template.size, all-keys) + else + apply(make, type, size: desired-size, all-keys) + end if + else + apply(make, type, all-keys) + end if +end method; + +define inline method make-sequence + (type :: , #rest all-keys, + #key shaped-like: template :: false-or(), + size: desired-size :: false-or()) + => (new-instance :: ) + let all-keys = remove-keyword-arguments(all-keys, #[ size: ]); + if (instance?(template, )) + if (~desired-size | desired-size = template.size) + apply(make, type, dimensions: template.dimensions, all-keys) + else + apply(make, type, dimensions: vector(desired-size), all-keys) + end if + elseif (template) + if (~desired-size | desired-size = template.size) + apply(make, type, dimensions: vector(template.size), all-keys) + else + apply(make, type, dimensions: vector(desired-size), all-keys) + end if + elseif (desired-size) + apply(make, type, dimensions: vector(desired-size), all-keys) + else + apply(make, type, all-keys) + end if +end method; + +define inline method make-sequence + (type :: , #rest all-keys, + #key shaped-like: template :: false-or(), + size: desired-size :: false-or()) + => (new-instance :: ) + if (template) + if (~desired-size | desired-size = template.size) + apply(make, type, size: template.size, all-keys) + else + apply(make, type, size: desired-size, all-keys) + end if + else + apply(make, type, all-keys) + end if +end method; + //////////// // INTERFACE @@ -18,15 +98,11 @@ define sealed generic concatenate (sequence1 :: , #rest sequences :: ) => (result-sequence :: ); -define constant - = type-union(subclass(), ); - -define constant - = type-union(subclass(), ); - +// This generic is defined on because the DRM says so and the test suite +// expects it to be so. However, the methods top out with +// and this generic is sealed, so there should not be a dispatch hit. define sealed generic concatenate-as - (type :: , - sequence1 :: , #rest more-sequences :: ) + (type :: , sequence1 :: , #rest more-sequences :: ) => (result-sequence :: ); define sealed generic first @@ -177,7 +253,7 @@ define method concatenate-as( without-bounds-checks let fill = if (non-empty-index = 0) first-seq[0] else rest-seqs[non-empty-index - 1][0] end; - let result = make(type, size: total-sz, fill: fill); + let result = make-sequence(type, size: total-sz, fill: fill); with-fip-of result let state = initial-state; for (val in first-seq) @@ -207,8 +283,8 @@ define method concatenate-as-two empty?(first-seq) => as(type, second-seq); empty?(second-seq) => as(type, first-seq); otherwise => - let result = make(type, size: first-seq.size + second-seq.size, - fill: first-seq[0]); + let result = make-sequence(type, size: first-seq.size + second-seq.size, + fill: first-seq[0]); without-bounds-checks for (val in first-seq, key from 0) result[key] := val; @@ -516,7 +592,8 @@ define method copy-sequence if (first = last) as(type-for-copy(source), #()) else let result = - make(type-for-copy(source), size: last - first, fill: source[0]); + make-sequence(type-for-copy(source), shaped-like: source, + size: last - first, fill: source[0]); with-fip-of source for (index from 0 below first, diff --git a/sources/dylan/stretchy-vector.dylan b/sources/dylan/stretchy-vector.dylan index b7a1a93a2b..aeb24e36fc 100644 --- a/sources/dylan/stretchy-vector.dylan +++ b/sources/dylan/stretchy-vector.dylan @@ -67,7 +67,7 @@ end class ; define open generic limited-stretchy-vector - (of :: false-or()) => (type :: ); + (of :: false-or(), fill) => (type :: ); ///////////////// @@ -116,15 +116,13 @@ define class () end; // SHARED-STRETCHY-VECTOR // -define open class () +define open class (, ) end class; define open primary class () slot %size :: , required-init-keyword: size:; end class; -define open generic collection-fill - (x :: ) => (res); define open generic stretchy-representation (x :: ) => (res :: ); @@ -145,11 +143,6 @@ define open generic stretchy-vector-element-setter => (value :: ); -define method collection-fill (x :: ) => (res) - #f -end method; - - // // EMPTY? // @@ -166,12 +159,7 @@ end method empty?; define inline method add! (vector :: , new-element) => (v :: ) - let old-size = vector.size; - trusted-size(vector) := old-size + 1; - check-type(new-element, element-type(vector)); - without-bounds-checks - vector[old-size] := new-element; - end without-bounds-checks; + vector[vector.size] := new-element; vector end method add!; @@ -181,41 +169,39 @@ end method add!; // define method trusted-size-setter - (new-size :: , vector :: ) - => (new-size :: ) - // TODO: could remove fills and do this in size-setter + (new-size :: , vector :: , + #key fill = vector.element-type-fill) + => (new-size :: ) + check-type(fill, vector.element-type); let v = vector.stretchy-representation; - if (new-size > v.size) + let v-capacity = v.size; + let v-size = v.%size; + if (new-size > v-capacity) let nv :: = make(stretchy-representation-type(vector), capacity: new-size.power-of-two-ceiling, size: new-size); - for (i :: from 0 below v.%size) + for (i :: from 0 below v-size) stretchy-vector-element(nv, i) := stretchy-vector-element(v, i) finally for (j :: from i below new-size) - stretchy-vector-element(nv, j) := collection-fill(vector) + stretchy-vector-element(nv, j) := fill end for; end for; vector.stretchy-representation := nv; - new-size; - elseif (new-size < v.%size) - let s = v.%size; - v.%size := new-size; - for (i :: from new-size below s) - stretchy-vector-element(v, i) := collection-fill(vector) - end for; - new-size; else - v.%size := new-size + for (i :: from v-size below new-size) + stretchy-vector-element(v, i) := fill + end for; + v.%size := new-size; end if; + new-size end method trusted-size-setter; define method size-setter (new-size :: , vector :: ) => (new-size :: ) check-nat(new-size); - let size = size(vector); trusted-size(vector) := new-size; end method size-setter; @@ -245,8 +231,10 @@ define method remove! grovel(count, src-index + 1, dst-index + 1) end case else + let fill = vector.element-type-fill; + check-type(fill, vector.element-type); for (i :: from dst-index below src-index) - stretchy-vector-element(src, i) := collection-fill(vector) + stretchy-vector-element(src, i) := fill end; src.%size := dst-index end if @@ -311,11 +299,6 @@ define macro limited-stretchy-vector-minus-constructor-definer vector end method as; - define sealed inline method collection-fill - (vector :: "") => (res) - ?fill - end method; - define sealed inline method stretchy-representation-type (vector :: "") => (res :: singleton("")) @@ -331,7 +314,7 @@ define macro limited-stretchy-vector-minus-constructor-definer define sealed inline method element (collection :: "", index :: , #key default = unsupplied()) - => (object :: "<" ## ?name ## ">") + => (object) let v = collection.stretchy-representation; if (element-range-check(index, v.%size)) "stretchy-" ## ?name ## "-vector-element"(v, index) @@ -339,7 +322,6 @@ define macro limited-stretchy-vector-minus-constructor-definer if (unsupplied?(default)) element-range-error(collection, index) else - check-type(default, element-type(collection)); default end if end if @@ -479,7 +461,6 @@ define macro limited-stretchy-vector-minus-constructor-definer identity-copy-state) end method backward-iteration-protocol; - define sealed domain element-type (""); define sealed domain make (singleton("")); define sealed domain initialize (""); @@ -518,8 +499,7 @@ define macro limited-stretchy-vector-minus-constructor-definer make("", size: 0); else let new-vector :: "" - = make("", - size: size, fill: collection[0]); + = make("", size: size); let d = new-vector.stretchy-representation; without-bounds-checks for (item in collection, index :: from 0) @@ -532,7 +512,8 @@ define macro limited-stretchy-vector-minus-constructor-definer define sealed copy-down-method trusted-size-setter (new-size :: , - vector :: "") + vector :: "", + #key fill = vector.element-type-fill) => (new-size :: ); define sealed copy-down-method size-setter @@ -585,11 +566,14 @@ define macro limited-stretchy-vector-minus-selector-definer define method initialize (vector :: "", #key size :: = 0, capacity :: = size, - fill :: "<" ## ?name ## ">" = ?fill) + fill = ?fill, element-type-fill: default-fill = ?fill) => () ?=next-method(); + unless (size = 0) + check-type(fill, "<" ## ?name ## ">") + end unless; + vector.element-type-fill := default-fill; stretchy-initialize(vector, capacity, size, fill); - vector end method initialize; define sealed inline method element-type @@ -605,59 +589,57 @@ define macro limited-stretchy-vector-minus-selector-definer if (index < 0) element-range-error(collection, index) end if; - if (index >= collection.size) - if (index = collection.size) - trusted-size(collection) := index + 1; - else - collection.size := index + 1 - end if - end if; // We assume here that the underlying vector only grows. // If this ceases to be true the following code will need to be changed. - "stretchy-" ## ?name ## "-vector-element" - (collection.stretchy-representation, index) := new-value + if (index = collection.size) + trusted-size-setter(index + 1, collection, fill: new-value); + new-value + else + if (index > collection.size) + collection.size := index + 1 + end if; + "stretchy-" ## ?name ## "-vector-element" + (collection.stretchy-representation, index) := new-value + end if; end method element-setter; define sealed inline method type-for-copy (vector :: "") => (type :: ) - "" - end method type-for-copy } + limited-stretchy-vector(element-type(vector), element-type-fill(vector)) + end method type-for-copy; + } end macro; define macro limited-stretchy-vector-definer { define limited-stretchy-vector "<" ## ?:name ## ">" (#key ?fill:expression) } - => { define limited-stretchy-vector-minus-selector "<" ## ?name ## ">" () - (fill: ?fill); + => { define limited-stretchy-vector-minus-selector "<" ## ?name ## ">" + () (fill: ?fill); + define method concrete-limited-stretchy-vector-class - (of == "<" ## ?name ## ">") => (res :: ) - "" + (of == "<" ## ?name ## ">", default-fill) + => (res :: , fully-specified? :: ) + values("", default-fill = ?fill) end method } end macro; -define limited-stretchy-vector (fill: #f); +define limited-stretchy-vector (fill: #f); define method limited-stretchy-vector - (of :: ) => (type :: ) - let concrete-class - = concrete-limited-stretchy-vector-class(of); - let default-concrete-class - = ; - if (size | concrete-class == default-concrete-class) + (of :: , default-fill :: ) => (type :: ) + let (concrete-class, fully-specified?) + = concrete-limited-stretchy-vector-class(of, default-fill); + if (~fully-specified?) make(, class: , element-type: of, - concrete-class: default-concrete-class); + default-fill: default-fill, + concrete-class: concrete-class); else concrete-class end if; end method; -define method limited - (class == , #key of :: = , #all-keys) => (type :: ) - limited-stretchy-vector(of) -end method; - define inline copy-down-method map-into-stretchy-one (fun :: , target :: , coll :: ) => (target :: ); diff --git a/sources/dylan/string-speed.dylan b/sources/dylan/string-speed.dylan index f2ea9c3c9b..b5825077be 100644 --- a/sources/dylan/string-speed.dylan +++ b/sources/dylan/string-speed.dylan @@ -106,7 +106,7 @@ define sealed method copy-sequence => (result-sequence :: ); let last :: = check-start-compute-end(source, first, last); let sz :: = last - first; - let target :: = make(, size: sz); + let target :: = make(type-for-copy(source), size: sz); primitive-replace-bytes! (target, primitive-repeated-slot-offset(target), integer-as-raw(0), source, primitive-repeated-slot-offset(source), integer-as-raw(first), diff --git a/sources/dylan/string.dylan b/sources/dylan/string.dylan index 1212fb4bc1..57d44c32ac 100644 --- a/sources/dylan/string.dylan +++ b/sources/dylan/string.dylan @@ -45,50 +45,32 @@ end method make; // define macro shared-string-definer - { define shared-string ?:name (#key ?fill:expression) } - => { define method make - (class == "<" ## ?name ## "-string>", - #key fill :: "<" ## ?name ## "-character>" = ?fill, size :: = 0) - => (res :: "<" ## ?name ## "-string>") - if (size = 0) - empty(class) - else - system-allocate-repeated-instance - ("<" ## ?name ## "-string>", "<" ## ?name ## "-character>", unbound(), size, fill); - end if - end method; - - define sealed inline method concrete-limited-string-class - (of == "<" ## ?name ## "-character>") - => (type :: singleton("<" ## ?name ## "-string>")) - "<" ## ?name ## "-string>" - end method; - - define inline sealed method element - (string :: "<" ## ?name ## "-string>", index :: , + { define shared-string ?:name (#key ?fill:expression, ?class-name:name) } + => { define inline sealed method element + (string :: "<" ## ?class-name ## "-string>", index :: , #key default = unsupplied()) - => (character :: "<" ## ?name ## "-character>") + => (character) if (element-range-check(index, size(string))) string-element(string, index) else if (unsupplied?(default)) element-range-error(string, index) else - check-type(default, element-type(string)); default end if end if end method element; define inline sealed method element-no-bounds-check - (string :: "<" ## ?name ## "-string>", index :: , #key default) + (string :: "<" ## ?class-name ## "-string>", + index :: , #key default) => (character :: "<" ## ?name ## "-character>") string-element(string, index) end method element-no-bounds-check; define inline sealed method element-setter (new-value :: "<" ## ?name ## "-character>", - string :: "<" ## ?name ## "-string>", index :: ) + string :: "<" ## ?class-name ## "-string>", index :: ) => (character :: "<" ## ?name ## "-character>") if (element-range-check(index, size(string))) string-element(string, index) := new-value @@ -99,64 +81,60 @@ define macro shared-string-definer define inline sealed method element-setter (new-value :: , - string :: "<" ## ?name ## "-string>", index :: ) + string :: "<" ## ?class-name ## "-string>", index :: ) => (character :: "<" ## ?name ## "-character>") string[index] := as("<" ## ?name ## "-character>", new-value); end method element-setter; define inline sealed method element-no-bounds-check-setter (new-value :: "<" ## ?name ## "-character>", - string :: "<" ## ?name ## "-string>", index :: ) + string :: "<" ## ?class-name ## "-string>", index :: ) => (character :: "<" ## ?name ## "-character>") string-element(string, index) := new-value end method element-no-bounds-check-setter; define inline sealed method element-no-bounds-check-setter (new-value :: , - string :: "<" ## ?name ## "-string>", index :: ) + string :: "<" ## ?class-name ## "-string>", index :: ) => (character :: "<" ## ?name ## "-character>") string-element(string, index) := as("<" ## ?name ## "-character>", new-value); end method element-no-bounds-check-setter; - define sealed inline method type-for-copy - (object :: "<" ## ?name ## "-string>") => (c :: ) - "<" ## ?name ## "-string>" - end method type-for-copy; - define sealed inline method element-type - (t :: "<" ## ?name ## "-string>") => (type :: ) + (t :: "<" ## ?class-name ## "-string>") => (type :: ) "<" ## ?name ## "-character>" end method; - + define sealed inline method as - (class == "<" ## ?name ## "-string>", string :: "<" ## ?name ## "-string>") - => (s :: "<" ## ?name ## "-string>") + (class == "<" ## ?class-name ## "-string>", + string :: "<" ## ?class-name ## "-string>") + => (s :: "<" ## ?class-name ## "-string>") string end method as; define method as - (class == "<" ## ?name ## "-string>", collection :: ) - => (s :: "<" ## ?name ## "-string>") - let new-string :: "<" ## ?name ## "-string>" - = make("<" ## ?name ## "-string>", size: collection.size); - replace-subsequence!(new-string, collection); + (class == "<" ## ?class-name ## "-string>", coll :: ) + => (s :: "<" ## ?class-name ## "-string>") + let new-string :: "<" ## ?class-name ## "-string>" + = make("<" ## ?class-name ## "-string>", size: coll.size); + replace-subsequence!(new-string, coll); new-string end method as; - define inline function ?name ## "-string-current-element" - (string :: "<" ## ?name ## "-string>", state :: ) + define inline function ?class-name ## "-string-current-element" + (string :: "<" ## ?class-name ## "-string>", state :: ) string-element(string, state) end function; - define inline function ?name ## "-string-current-element-setter" - (new-value :: , string :: "<" ## ?name ## "-string>", + define inline function ?class-name ## "-string-current-element-setter" + (new-value :: , string :: "<" ## ?class-name ## "-string>", state :: ) string-element(string, state) := as("<" ## ?name ## "-character>", new-value); end function; define sealed inline method forward-iteration-protocol - (sequence :: "<" ## ?name ## "-string>") + (sequence :: "<" ## ?class-name ## "-string>") => (initial-state :: , limit :: , next-state :: , finished-state? :: , current-key :: , @@ -167,13 +145,13 @@ define macro shared-string-definer sequence-next-state, sequence-finished-state?, sequence-current-key, - ?name ## "-string-current-element", - ?name ## "-string-current-element-setter", + ?class-name ## "-string-current-element", + ?class-name ## "-string-current-element-setter", identity-copy-state) end method forward-iteration-protocol; define sealed inline method backward-iteration-protocol - (sequence :: "<" ## ?name ## "-string>") + (sequence :: "<" ## ?class-name ## "-string>") => (final-state :: , limit :: , previous-state :: , @@ -187,22 +165,23 @@ define macro shared-string-definer sequence-previous-state, sequence-finished-state?, sequence-current-key, - ?name ## "-string-current-element", - ?name ## "-string-current-element-setter", + ?class-name ## "-string-current-element", + ?class-name ## "-string-current-element-setter", identity-copy-state) end method backward-iteration-protocol; - define sealed domain size ("<" ## ?name ## "-string>"); - define sealed domain make (singleton("<" ## ?name ## "-string>")); - define sealed domain initialize ("<" ## ?name ## "-string>"); + define sealed domain size ("<" ## ?class-name ## "-string>"); + define sealed domain make (singleton("<" ## ?class-name ## "-string>")); + define sealed domain initialize ("<" ## ?class-name ## "-string>"); define inline sealed method empty? - (string :: "<" ## ?name ## "-string>") => (result :: ) + (string :: "<" ## ?class-name ## "-string>") => (result :: ) string.size = 0 end method empty?; define sealed method \< - (string-1 :: "<" ## ?name ## "-string>", string-2 :: "<" ## ?name ## "-string>") + (string-1 :: "<" ## ?class-name ## "-string>", + string-2 :: "<" ## ?class-name ## "-string>") => (well? :: ) let min-size :: = min(string-1.size, string-2.size); iterate grovel (index :: = 0) @@ -221,7 +200,8 @@ define macro shared-string-definer end method \<; define sealed method \= - (string-1 :: "<" ## ?name ## "-string>", string-2 :: "<" ## ?name ## "-string>") + (string-1 :: "<" ## ?class-name ## "-string>", + string-2 :: "<" ## ?class-name ## "-string>") => (eq :: ) unless (string-1.size ~= string-2.size) for (c1 :: "<" ## ?name ## "-character>" in string-1, @@ -235,7 +215,8 @@ define macro shared-string-definer end; define sealed method case-insensitive-equal - (string-1 :: "<" ## ?name ## "-string>", string-2 :: "<" ## ?name ## "-string>") + (string-1 :: "<" ## ?class-name ## "-string>", + string-2 :: "<" ## ?class-name ## "-string>") => (eq :: ) unless (string-1.size ~= string-2.size) for (c1 :: "<" ## ?name ## "-character>" in string-1, @@ -248,10 +229,11 @@ define macro shared-string-definer end end; - define sealed method as-lowercase (string :: "<" ## ?name ## "-string>") - => (new-string :: "<" ## ?name ## "-string>") - let new-string :: "<" ## ?name ## "-string>" - = make("<" ## ?name ## "-string>", size: string.size); + define sealed method as-lowercase + (string :: "<" ## ?class-name ## "-string>") + => (new-string :: "<" ## ?class-name ## "-string>") + let new-string :: "<" ## ?class-name ## "-string>" + = make("<" ## ?class-name ## "-string>", size: string.size); for (i :: from 0 below string.size) string-element(new-string, i) := as-lowercase(string-element(string, i)) @@ -259,8 +241,9 @@ define macro shared-string-definer new-string end method as-lowercase; - define sealed method as-lowercase! (string :: "<" ## ?name ## "-string>") - => (string :: "<" ## ?name ## "-string>") + define sealed method as-lowercase! + (string :: "<" ## ?class-name ## "-string>") + => (string :: "<" ## ?class-name ## "-string>") for (i :: from 0 below string.size) string-element(string, i) := as-lowercase(string-element(string, i)) @@ -268,10 +251,11 @@ define macro shared-string-definer string end method as-lowercase!; - define sealed method as-uppercase (string :: "<" ## ?name ## "-string>") - => (new-string :: "<" ## ?name ## "-string>") - let new-string :: "<" ## ?name ## "-string>" - = make("<" ## ?name ## "-string>", size: string.size); + define sealed method as-uppercase + (string :: "<" ## ?class-name ## "-string>") + => (new-string :: "<" ## ?class-name ## "-string>") + let new-string :: "<" ## ?class-name ## "-string>" + = make("<" ## ?class-name ## "-string>", size: string.size); for (i :: from 0 below string.size) string-element(new-string, i) := as-uppercase(string-element(string, i)) @@ -279,8 +263,9 @@ define macro shared-string-definer new-string end method as-uppercase; - define sealed method as-uppercase! (string :: "<" ## ?name ## "-string>") - => (string :: "<" ## ?name ## "-string>") + define sealed method as-uppercase! + (string :: "<" ## ?class-name ## "-string>") + => (string :: "<" ## ?class-name ## "-string>") for (i :: from 0 below string.size) string-element(string, i) := as-uppercase(string-element(string, i)) @@ -290,10 +275,20 @@ define macro shared-string-definer } end macro; -define macro string-definer - { define string ?:name (#key ?fill:expression) } - => { define shared-string ?name (fill: ?fill); - define sealed concrete primary class "<" ## ?name ## "-string>" (, ) +// +// LIMITED AND NOT LIMITED STRINGS +// + +define constant + = type-union(subclass(), ); + +// Defines class and methods for a . +define macro limited-string-definer + { define limited-string ?:name (#key ?fill:expression) } + => { define shared-string ?name (fill: ?fill, class-name: "limited-" ## ?name); + + define sealed concrete primary class "" + (, , ) repeated sealed inline slot string-element :: "<" ## ?name ## "-character>", init-value: ?fill, init-keyword: fill:, @@ -302,27 +297,121 @@ define macro string-definer size-init-value: 0; end class; - define constant "$empty-<" ## ?name ## "-string>" - = system-allocate-repeated-instance - ("<" ## ?name ## "-string>", "<" ## ?name ## "-character>", unbound(), 0, ?fill); + define method make + (class == "", + #key fill = ?fill, size :: = 0, + element-type-fill: default-fill = ?fill) + => (res :: "") + // The user is not obligated to provide a fill value of the right type + // if we won't be needing it, but the fill variable does have to be the + // right type for the compiler to optimize system-allocate-repeated-instance. + let fill :: "<" ## ?name ## "-character>" + = if (size = 0) + ?fill + else + check-type(fill, "<" ## ?name ## "-character>") + end; + let instance :: "" + = system-allocate-repeated-instance + ("", "<" ## ?name ## "-character>", unbound(), size, fill); + instance.element-type-fill := default-fill; + instance + end method; + + define sealed inline method type-for-copy + (object :: "") => (c :: ) + limited-string(element-type(object), element-type-fill(object), #f) + end method type-for-copy; - define sealed method empty - (class == "<" ## ?name ## "-string>") => (res :: "<" ## ?name ## "-string>") - "$empty-<" ## ?name ## "-string>" - end method; } + define sealed inline method concrete-limited-string-class + (of == "<" ## ?name ## "-character>", default-fill) + => (type :: singleton(""), fully-specified? :: ) + values("", default-fill = ?fill) + end method; + + define sealed inline method limited-string-default-fill + (of == "<" ## ?name ## "-character>") => (fill :: "<" ## ?name ## "-character>") + ?fill + end method; + } end macro; -define constant - = type-union(subclass(), ); +// Defines class and methods for an . The class was +// defined from boot, so use string-without-class alone for it. +define macro string-definer + { define string ?:name (#key ?fill:expression) } + => { define string-without-class ?name (fill: ?fill); + + define sealed concrete primary class "<" ## ?name ## "-string>" (, ) + repeated sealed inline slot string-element :: "<" ## ?name ## "-character>", + init-value: ?fill, + init-keyword: fill:, + size-getter: size, + size-init-keyword: size:, + size-init-value: 0; + end class; + + define method make + (class == "<" ## ?name ## "-string>", + #key fill = ?fill, size :: = 0) + => (res :: "<" ## ?name ## "-string>") + if (size = 0) + empty(class) + else + // The user is not obligated to provide a fill value of the right type + // if we won't be needing it, but the fill variable does have to be the + // right type for the compiler to optimize system-allocate-repeated-instance. + let fill :: "<" ## ?name ## "-character>" + = check-type(fill, "<" ## ?name ## "-character>"); + system-allocate-repeated-instance + ("<" ## ?name ## "-string>", "<" ## ?name ## "-character>", unbound(), size, fill); + end if + end method; + + define constant "$empty-<" ## ?name ## "-string>" + = system-allocate-repeated-instance + ("<" ## ?name ## "-string>", "<" ## ?name ## "-character>", unbound(), 0, ?fill); + + define sealed method empty + (class == "<" ## ?name ## "-string>") => (res :: "<" ## ?name ## "-string>") + "$empty-<" ## ?name ## "-string>" + end method; + } +end macro; + +// Defines methods for an class. +define macro string-without-class-definer + { define string-without-class ?:name (#key ?fill:expression) } + => { define shared-string ?name (fill: ?fill, class-name: ?name); + + define sealed inline method type-for-copy + (object :: "<" ## ?name ## "-string>") => (c :: ) + "<" ## ?name ## "-string>" + end method type-for-copy; + + define sealed inline method element-type-fill + (t :: "<" ## ?name ## "-string>") => (fill :: "<" ## ?name ## "-character>") + ?fill + end method; + } +end macro; + +// +// LIMITED STRINGS +// + +define limited-string byte (fill: as(, ' ')); define method limited-string - (of :: , size :: false-or()) => (type :: ) - let concrete-class - = concrete-limited-string-class(of); - if (size) + (of :: , default-fill :: , size :: false-or()) + => (type :: ) + let (concrete-class, fully-specified?) + = concrete-limited-string-class(of, default-fill); + if (size | ~fully-specified?) make(, class: , element-type: of, + default-fill: default-fill, concrete-class: concrete-class, size: size) else @@ -330,14 +419,40 @@ define method limited-string end if; end method; +define sealed inline method concrete-limited-string-class + (of == , default-fill) + => (type :: subclass(), fully-specified? :: ) + values(, default-fill = limited-string-default-fill(of)) +end method; + +define sealed inline method limited-string-default-fill + (of :: ) => (fill == ' ') + ' ' +end method; + // // BYTE-STRING // // BOOTED: define ... class ... end; +define string-without-class byte (fill: ' ', class-name: byte); -define shared-string byte (fill: ' '); +define method make + (class == , #key fill = as(, ' '), + size :: = 0) + => (res :: ) + if (size = 0) + empty(class) + else + // The user is not obligated to provide a fill value of the right type + // if we won't be needing it, but the fill variable does have to be the + // right type for the compiler to optimize system-allocate-repeated-instance. + let fill :: = check-type(fill, ); + system-allocate-repeated-instance + (, , unbound(), size, fill); + end if +end method; define sealed method empty (class == ) => (res :: ) diff --git a/sources/dylan/table.dylan b/sources/dylan/table.dylan index a5d157b4cc..ec249aa8cd 100644 --- a/sources/dylan/table.dylan +++ b/sources/dylan/table.dylan @@ -1050,7 +1050,7 @@ define generic grow-size-function (t ::
) // ----------------
---------------- define open abstract primary class
- (, , ) + (, , ) slot table-vector :: , init-value: initial-table-vector(); constant slot initial-entries :: , @@ -1065,8 +1065,6 @@ define open abstract primary class
// slot rehash-table-vector :: false-or() = #f; end class
; -define sealed domain element-type (
); - define class (
) end class ; @@ -1167,7 +1165,6 @@ define function gethash // --- Signal some more specific class of error? key-missing-error(table, key, default); else - check-type(default, element-type(table)); default; end if; end; diff --git a/sources/dylan/tests/collections.dylan b/sources/dylan/tests/collections.dylan index 62c1c8cdc8..4c311c7267 100644 --- a/sources/dylan/tests/collections.dylan +++ b/sources/dylan/tests/collections.dylan @@ -20,6 +20,9 @@ define method test-collection-class (class :: subclass(), #key name, instantiable?, #all-keys) => () if (instantiable?) + if (instantiable-as-limited?(class)) + test-limited(name, class) + end if; test-collection-of-size(format-to-string("Empty %s", name), class, 0); test-collection-of-size(format-to-string("One item %s", name), class, 1); test-collection-of-size(format-to-string("Even size %s", name), class, 4); @@ -88,27 +91,50 @@ define method test-collection-of-size size(collection), collection-size); check-equal(format-to-string("%s = shallow-copy", individual-name), shallow-copy(collection), collection); + // This check is done differently for limited collections. + unless (instantiable-as-limited?(class)) + check-true(format-to-string("%s element-type", individual-name), + subtype?(collection-element-type(collection), + collection-type-element-type(class))); + if (collection-type-is-fillable?(class)) + check-equal(format-to-string("%s element-type-fill", individual-name), + collection-element-type-fill(collection), + collection-type-element-type-fill(class)); + end if; + end unless; test-collection(individual-name, collection) end; - test-limited-collection-of-size(name, class, collection-size) + if (instantiable-as-limited?(class)) + test-limited-collection-of-size(name, class, collection-size) + end if end method test-collection-of-size; define method test-limited-collection-of-size (name :: , class :: , collection-size :: ) => () let collections = #[]; + let element-types = #[]; let name = format-to-string("Limited %s", name); + let (collections, element-types) + = make-limited-collections-of-size(class, collection-size); check(format-to-string("%s creation", name), - always(#t), - collections := make-limited-collections-of-size(class, collection-size)); - for (collection in collections) + always(#t), collections); + for (collection in collections, expected-element-type in element-types) let individual-name = format-to-string("%s of %s", name, element-type(collection)); + let expected-fill = limited-collection-default-fill(expected-element-type); check-equal(format-to-string("%s empty?", individual-name), empty?(collection), collection-size == 0); check-equal(format-to-string("%s size", individual-name), size(collection), collection-size); check-equal(format-to-string("%s = shallow-copy", individual-name), shallow-copy(collection), collection); + check-true(format-to-string("%s element-type", individual-name), + subtype?(collection-element-type(collection), + expected-element-type)); + if (collection-type-is-fillable?(class)) + check-equal(format-to-string("%s element-type-fill", individual-name), + collection-element-type-fill(collection), expected-fill); + end if; test-collection(individual-name, collection) end end method test-limited-collection-of-size; @@ -192,48 +218,42 @@ define method make-collections-of-size end end method make-collections-of-size; +define variable $base-type-for-limited-collection = make(
); + define method make-limited-collections-of-size (class :: , collection-size :: ) - => (collections :: ) + => (collections :: , element-types :: ) let sequences = make(); let element-types = limited-collection-element-types(class); for (element-type :: in element-types) - let type = limited(class, of: element-type); - if (subtype?(, element-type)) - add!(sequences, as(type, range(from: 1, to: collection-size))) - end; - if (subtype?(, element-type)) - add!(sequences, - if (collection-size < size($default-string)) - as(type, copy-sequence($default-string, end: collection-size)); - else - make(type, size: collection-size, fill: 'a'); - end) - end; - if (subtype?(, element-type)) - add!(sequences, - if (collection-size < size($default-vectors)) - as(type, copy-sequence($default-vectors, end: collection-size)); - else - make(type, size: collection-size, fill: #[]); - end) - end + let default-fill = limited-collection-default-fill(element-type); + let type = limited(class, of: element-type, default-fill: default-fill); + let collection = + case + subtype?(, element-type) => + as(type, range(from: 1, to: collection-size)); + subtype?(, element-type) => + if (collection-size < size($default-string)) + as(type, copy-sequence($default-string, end: collection-size)); + else + make(type, size: collection-size, fill: 'a'); + end; + subtype?(, element-type) => + if (collection-size < size($default-vectors)) + as(type, copy-sequence($default-vectors, end: collection-size)); + else + make(type, size: collection-size, fill: #[]); + end; + end case; + add!(sequences, collection); + $base-type-for-limited-collection[collection] := class; end; - // Only return one for size 0, because they are all the same - if (collection-size = 0) - if (size(sequences) > 0) - vector(sequences[0]) - else - #[] - end if - else - sequences - end + values(sequences, element-types) end method make-limited-collections-of-size; define method make-limited-collections-of-size (class :: subclass(
), collection-size :: ) - => (tables :: ) + => (tables :: , element-types :: ) let table-1 = make(limited(
, of: )); let table-2 = make(limited(
, of: )); for (i from 0 below collection-size, @@ -241,13 +261,15 @@ define method make-limited-collections-of-size table-1[i] := i + 1; table-2[i] := char; end; - vector(table-1, table-2) + $base-type-for-limited-collection[table-1] :=
; + $base-type-for-limited-collection[table-2] :=
; + values(vector(table-1, table-2), vector(, )) end method make-limited-collections-of-size; define method make-limited-collections-of-size (class :: subclass(), collection-size :: ) - => (pairs :: ) - #[] + => (pairs :: , element-types :: ) + values(#[], #[]) end method make-limited-collections-of-size; define method expected-element @@ -268,7 +290,7 @@ define method expected-element else 'a' end; - , => + , , => index + 1; => if (size(collection) < size($default-vectors)) @@ -293,7 +315,7 @@ end method collection-type-element-type; define method collection-type-element-type (class :: subclass()) => (element-type :: ) - + end method collection-type-element-type; define method collection-type-element-type @@ -301,12 +323,37 @@ define method collection-type-element-type end method collection-type-element-type; +define method collection-type-element-type-fill + (class :: subclass()) => (fill) + #f +end method; + +define method collection-type-element-type-fill + (class :: subclass()) => (fill) + ' ' +end method; + +define method collection-type-is-fillable? + (class :: subclass()) => (fillable? :: ) + case + class == => #f; + class == => #f; + class == => #f; + otherwise => subtype?(class, ); + end +end method; + define method collection-element-type (collection :: ) => (element-type :: ) element-type(collection) end method collection-element-type; +define method collection-element-type-fill + (collection :: ) => (element-type-fill :: ) + element-type-fill(collection) +end method collection-element-type-fill; + define method limited-collection-element-types (class :: subclass()) => (element-types :: ) @@ -323,6 +370,18 @@ define method limited-collection-element-types #[] end method limited-collection-element-types; + +define function limited-collection-default-fill + (element-type :: ) => (fill :: ) + select (element-type by subtype?) + => 42; + => 'q'; + => #[ "default-fill" ]; + otherwise => #f; + end select +end function; + + define generic collection-default (type :: ) => (res); define method collection-default (type :: ) => (res) @@ -603,6 +662,17 @@ define method proper-collection? end end method proper-collection?; +define function instantiable-as-limited? (class :: ) + => (inst? :: ) + case + class == => #f; + class == => #f; + class == => #f; + subtype?(class, ) => #f; + otherwise => #t; + end case +end function; + /// collection-valid-as-class? /// @@ -684,6 +754,12 @@ end method collection-valid-as-class?; /// Collection testing +define method test-limited + (name :: , class :: ) => () + check-true(format-to-string("Limited %s with invalid default-fill", name), + limited(class, of: , default-fill: #f)) +end method; + define method test-as (name :: , collection :: ) => () let spec = $collections-protocol-spec; @@ -834,9 +910,9 @@ define method test-element element(collection, -1, default: default), default); unless (type == ) - check-condition(format-to-string("%s element wrong default type errors", name), - , - element(collection, -1, default: #"wrong-default-type")); + check-equal(format-to-string("%s element wrong default type allowed", name), + element(collection, -1, default: #"wrong-default-type"), + #"wrong-default-type"); end unless; for (key in key-sequence(collection)) check-equal(format-to-string("%s element %=", name, key), @@ -981,14 +1057,23 @@ end method valid-type-for-copy?; define method valid-type-for-copy? (type :: , collection :: ) => (valid-type? :: ) - //--- The DRM pg. 293 says that this should be == object-class(collection) - //--- but that doesn't work in the emulator. Which should it be? - if (instance?(collection, )) - instance?(collection, type) + subtype?(object-class(collection), type) + & next-method() +end method valid-type-for-copy?; + +define method valid-type-for-copy? + (type :: , collection :: ) + => (valid-type? :: ) + let base-type = element($base-type-for-limited-collection, collection, default: #f); + if (base-type) + let instance-of-type = make(type, dimensions: #[0]); + subtype?(type, base-type) + & instance-of-type.element-type = collection.element-type + & instance-of-type.element-type-fill = collection.element-type-fill else - subtype?(object-class(collection), type) + next-method() end if -end method valid-type-for-copy?; +end method; define method valid-type-for-copy? (type :: , collection :: ) @@ -1011,20 +1096,26 @@ define method test-size-setter (name :: , collection :: ) => () if (instance?(collection, )) let new-size = size(collection) + 5; - if (instance?(#f, collection-element-type(collection))) - check-equal(format-to-string("%s resizes", name), - begin - size(collection) := new-size; - size(collection) - end, - new-size) - end; + check-equal(format-to-string("%s resizes", name), + begin + size(collection) := new-size; + size(collection) + end, + new-size); check-equal(format-to-string("%s emptied", name), begin size(collection) := 0; size(collection) end, 0); + if (instance?(collection, )) + check-equal(format-to-string("%s size-setter fills with default", name), + begin + size(collection) := new-size; + element(collection, new-size - 1) + end, + limited-collection-default-fill(collection.element-type)) + end if end end method test-size-setter; @@ -1383,9 +1474,7 @@ define method test-nth-setter nth-setter(item, copy); copy[n] = item end); - instance?(sequence, ) - & (n = size(sequence) | - instance?(#f, collection-element-type(sequence))) => + instance?(sequence, ) => check-true(name, begin let copy = shallow-copy(sequence); @@ -1667,6 +1756,10 @@ define collections function-test reverse! () end; define collections function-test sort () end; define collections function-test sort! () end; +/// DEP-0007 +define collections function-test element-type () end; +define collections function-test element-type-fill () end; + /// Mapping and reducing define collections function-test do () end; define collections function-test map () end; diff --git a/sources/dylan/tests/specification.dylan b/sources/dylan/tests/specification.dylan index 6797be8b35..03486ce6ea 100644 --- a/sources/dylan/tests/specification.dylan +++ b/sources/dylan/tests/specification.dylan @@ -130,15 +130,17 @@ define protocol-spec collections () function head-setter (, ) => (); function tail-setter (, ) => (); open generic-function add (, ) => (); - open generic-function add! (, ) => (); + //--- DRM defines add! for , but OD supports it for all . + open generic-function add! (, ) => (); open generic-function add-new (, , #"key", #"test") => (); open generic-function add-new! (, , #"key", #"test") => (); open generic-function remove (, , #"key", #"test", #"count") => (); + //--- DRM defines remove! for , but OD supports it for all . open generic-function remove! - (, , #"key", #"test", #"count") => (); + (, , #"key", #"test", #"count") => (); open generic-function push (, ) => (); open generic-function pop () => (); open generic-function push-last (, ) => (); @@ -150,6 +152,12 @@ define protocol-spec collections () open generic-function sort! (, #"key", #"test", #"stable") => (); + /// DEP-0007 + open generic-function element-type + () => (); + open generic-function element-type-fill + () => (); + /// Mapping and reducing function do (, , #"rest") => (singleton(#f)); function map (, , #"rest") => (); diff --git a/sources/dylan/type.dylan b/sources/dylan/type.dylan index 31031266a4..22d6a9f3ca 100644 --- a/sources/dylan/type.dylan +++ b/sources/dylan/type.dylan @@ -186,6 +186,35 @@ define generic has-instances? //// Limited types +// The user can create eight kinds of limited collections, depending on which +// limited keyword arguments he specifies. These tables shows each combination, +// the value returned by limited, and the corresponding concrete class that gets +// instantiated by calling make on that value. +// +// The tables are only *generally* accurate. A limited only has one +// concrete class, and a limited comes in and +// flavors. The concrete-limited-X-class functions +// return the specific concrete class for each case. +// +// of: default-fill: size:/dimensions: | limited value concrete class +// ----- ------------- ----------------- + ----------------------- ---------------------- +// T unspecified unspecified | +// T unspecified specified | +// T specified unspecified | +// T specified specified | +// other unspecified unspecified | +// other unspecified specified | +// other specified unspecified | +// other specified specified | +// +// concrete class properties in each instance +// --------------------------------- ------------------------------- +// element-type-fill +// element-type, element-type-fill +// +// X is the collection type and T one of the predefined limited collection +// element types, e.g., a may be . + // BOOTED: define ... class ... end; define generic limited (class :: , #key, #all-keys) @@ -193,10 +222,15 @@ define generic limited (class :: , #key, #all-keys) define generic limits (type :: ) => (class :: ); - + define method limited - (class == , #key of, size, #all-keys) => (type :: ) - limited-string(of, size) + (class == , + #key of :: = , + size :: false-or(), + default-fill :: = limited-string-default-fill(of), + #all-keys) + => (type :: ) + limited-string(of, default-fill, size) end method; define method limited @@ -214,17 +248,38 @@ define method limited end method; define method limited - (class == , - #key of :: = , size :: false-or(), #all-keys) + (class == , #rest all-keys, #key, #all-keys) => (type :: ) - limited-vector(of, size) + // Delegate to per DRM without defaulting any keyword args. + apply(limited, , all-keys) +end method; + +define method limited + (class == , + #key of :: = , + default-fill :: , + #all-keys) + => (type :: ) + limited-stretchy-vector(of, default-fill) end method; define method limited (class == , - #key of :: = , size, size :: false-or(), #all-keys) + #key of :: = , + size :: false-or(), + default-fill :: , + #all-keys) + => (type :: ) + limited-vector(of, default-fill, size) +end method; + +define method limited + (class == , + #key of :: = , + default-fill :: , + #all-keys) => (type :: ) - limited-vector(of, size) + limited-deque(of, default-fill) end method; define method limited @@ -232,6 +287,7 @@ define method limited #key of :: = , size: sz :: false-or(), dimensions :: false-or(), + default-fill :: , #all-keys) => (type :: ) if (sz) @@ -239,11 +295,11 @@ define method limited error("Dimensions %= incompatible to size %= in call to limited()", dimensions, sz); end if; - limited-vector(of, sz) + limited-vector(of, default-fill, sz) elseif (dimensions & size(dimensions) = 1) - limited-vector(of, first(dimensions)) + limited-vector(of, default-fill, first(dimensions)) else - limited-array(of, dimensions) + limited-array(of, default-fill, dimensions) end if end method; @@ -342,16 +398,43 @@ define sealed inline method make all-keys) end method; +define sealed inline method make + (t :: , #rest all-keys, #key fill = unsupplied(), #all-keys) + => (res :: ) + let fill = (supplied?(fill) & fill) | limited-collection-element-type-fill(t); + apply(make, limited-collection-concrete-class(t), + element-type: limited-collection-element-type(t), + element-type-fill: limited-collection-element-type-fill(t), + fill: fill, + all-keys) +end method; + +define sealed inline method make + (t :: , #rest all-keys, + #key fill = unsupplied(), #all-keys) + => (res :: ) + let fill = (supplied?(fill) & fill) | limited-collection-element-type-fill(t); + apply(make, limited-collection-concrete-class(t), + element-type: limited-collection-element-type(t), + element-type-fill: limited-collection-element-type-fill(t), + fill: fill, + all-keys); +end method; + define sealed inline method make (t :: , #rest all-keys, - #key size = unsupplied(), dimensions = unsupplied(), #all-keys) + #key size = unsupplied(), dimensions = unsupplied(), fill = unsupplied(), + #all-keys) => (res :: ) + let fill = (supplied?(fill) & fill) | limited-collection-element-type-fill(t); if (supplied?(size)) if (limited-collection-dimensions(t)) error("Incompatible size %= and limited array type %=.", size, t); else - apply(make, concrete-limited-vector-class(t), + apply(make, concrete-limited-vector-class(t, fill), element-type: limited-collection-element-type(t), + element-type-fill: limited-collection-element-type-fill(t), + fill: fill, size: size, all-keys) end if @@ -370,20 +453,25 @@ define sealed inline method make end if; apply(make, limited-collection-concrete-class(t), element-type: limited-collection-element-type(t), + element-type-fill: limited-collection-element-type-fill(t), dimensions: dims, + fill: fill, all-keys) end if end method; define sealed inline method make (t :: , #rest all-keys, - #key size = unsupplied(), #all-keys) + #key size = unsupplied(), fill = unsupplied(), #all-keys) => (res :: ) let concrete-class = limited-collection-concrete-class(t); let size :: = limited-collection-size(t) | (supplied?(size) & size) | 0; + let fill :: = (supplied?(fill) & fill) | limited-collection-element-type-fill(t); apply(make, concrete-class, element-type: limited-collection-element-type(t), + element-type-fill: limited-collection-element-type-fill(t), size: size, + fill: fill, all-keys); end method; diff --git a/sources/dylan/unicode-string.dylan b/sources/dylan/unicode-string.dylan index b6e446acda..a0ff0811ba 100644 --- a/sources/dylan/unicode-string.dylan +++ b/sources/dylan/unicode-string.dylan @@ -6,4 +6,6 @@ License: See License.txt in this distribution for details. Warranty: Distributed WITHOUT WARRANTY OF ANY KIND define string unicode (fill: as(, ' ')); +define limited-string unicode (fill: as(, ' ')); + diff --git a/sources/dylan/vector.dylan b/sources/dylan/vector.dylan index b91008efb3..3158511d83 100644 --- a/sources/dylan/vector.dylan +++ b/sources/dylan/vector.dylan @@ -45,7 +45,7 @@ end function; // define open generic limited-vector - (of :: false-or(), size :: false-or()) => (type :: ); + (of :: false-or(), fill, size :: false-or()) => (type :: ); ///////////////// @@ -108,6 +108,7 @@ end method empty?; // EMPTY // +// This method returns a shared sequence of the given type with the default fill. define open generic empty (class :: ) => (res :: ); @@ -651,7 +652,6 @@ define macro limited-vector-shared-definer define sealed domain type-for-copy (""); define sealed domain shallow-copy (""); define sealed domain size (""); - define sealed domain element-type (""); define sealed domain empty? (""); define sealed domain add ("", ); define sealed domain add! ("", ); @@ -702,6 +702,7 @@ define macro limited-vector-minus-constructor-definer { define limited-vector-minus-constructor "<" ## ?:name ## ">" (?superclasses:*) (#key ?fill:expression) } => { define limited-vector-shared "<" ## ?name ## ">"; + define sealed concrete primary class "" (?superclasses) repeated sealed inline slot ?name ## "-vector-element" :: "<" ## ?name ## ">", init-value: ?fill, @@ -710,18 +711,17 @@ define macro limited-vector-minus-constructor-definer size-init-keyword: size:, size-init-value: 0; end class; - + define inline sealed method element (vector :: "", index :: , #key default = unsupplied()) - => (object :: "<" ## ?name ## ">") + => (object) if (element-range-check(index, size(vector))) element-no-bounds-check(vector, index) else if (unsupplied?(default)) element-range-error(vector, index) else - check-type(default, element-type(vector)); default end if end if @@ -733,14 +733,17 @@ define macro limited-vector-minus-selector-definer { define limited-vector-minus-selector "<" ## ?:name ## ">" (?superclasses:*) (#key ?fill:expression) } => { define limited-vector-minus-constructor "<" ## ?name ## ">" (?superclasses) (fill: ?fill); define limited-vector-element-setter "<" ## ?name ## ">"; + define constant "$empty-" = system-allocate-repeated-instance ("", "<" ## ?name ## ">", unbound(), 0, ?fill); + define sealed inline method empty (class == "") => (res :: "") "$empty-" end method empty; + define sealed inline method element-type (t :: "") => (type :: ) "<" ## ?name ## ">" @@ -749,27 +752,44 @@ define macro limited-vector-minus-selector-definer // This method is not inline, because the typist needs to find it // in order to propagate limited collection type information. define method make - (class == "", - #key fill :: "<" ## ?name ## ">" = ?fill, size :: = 0) - => (vector :: "") - if (size = 0) - empty(class) - else - system-allocate-repeated-instance - ("", "<" ## ?name ## ">", unbound(), size, fill); - end if + (class == "", + #key fill = ?fill, size :: = 0, + element-type-fill: default-fill = ?fill) + => (vector :: "") + // The user is not obligated to provide a fill value of the right type + // if we won't be needing it, but the fill variable does have to be the + // right type for the compiler to optimize system-allocate-repeated-instance. + let fill :: "<" ## ?name ## ">" + = if (size = 0) + ?fill + else + check-type(fill, "<" ## ?name ## ">") + end; + let instance :: "" + = system-allocate-repeated-instance + ("", "<" ## ?name ## ">", unbound(), size, fill); + instance.element-type-fill := default-fill; + instance end method; + + define sealed inline method type-for-copy + (vector :: "") + => (type :: ) + limited-vector(element-type(vector), element-type-fill(vector), #f) + end method type-for-copy } end macro; define macro limited-vector-definer { define limited-vector "<" ## ?:name ## ">" (#key ?fill:expression) } - => { define limited-vector-minus-selector "<" ## ?name ## ">" () (fill: ?fill); + => { define limited-vector-minus-selector "<" ## ?name ## ">" + (, ) (fill: ?fill); + define sealed inline method concrete-limited-vector-class - (of == "<" ## ?name ## ">") - => (type :: singleton("")) - "" - end method; } + (of == "<" ## ?name ## ">", default-fill :: "<" ## ?name ## ">") + => (type :: singleton(""), fully-specified? :: ) + values("", default-fill = ?fill) + end method } end macro; define limited-vector-shared+element-setter ; @@ -777,20 +797,21 @@ define constant object-vector-element = vector-element; define constant object-vector-element-setter = vector-element-setter; define inline method concrete-limited-vector-class - (of :: ) => (res :: ) - + (of :: , default-fill) + => (res :: , fully-specified? :: ) + values(, #f) end method; define method limited-vector - (of :: , size :: false-or()) => (type :: ) - let concrete-class - = concrete-limited-vector-class(of); - let default-concrete-class - = ; - if (size | concrete-class == default-concrete-class) + (of :: , default-fill :: , size :: false-or()) + => (type :: ) + let (concrete-class, fully-specified?) + = concrete-limited-vector-class(of, default-fill); + if (size | ~fully-specified?) make(, - class: , + class: , element-type: of, + default-fill: default-fill, concrete-class: concrete-class, size: size) else @@ -798,6 +819,7 @@ define method limited-vector end if; end method; + // // // @@ -825,7 +847,8 @@ end method; // define method limited-vector - (of == , size :: false-or()) => (res :: ) + (of == , default-fill == #f, size :: false-or()) + => (res :: ) end method; diff --git a/sources/io/streams/multi-buffered-streams.dylan b/sources/io/streams/multi-buffered-streams.dylan index 8aa2178f0c..848ccd5f69 100644 --- a/sources/io/streams/multi-buffered-streams.dylan +++ b/sources/io/streams/multi-buffered-streams.dylan @@ -41,7 +41,8 @@ define function new-stream-id(the-stream :: ) end function; define constant = ; -define constant = limited(, of: ); +define constant = limited(, of: , + default-fill: 0); define constant $buffer-map-index-size = 24; // TODO: MACHINE INDEP diff --git a/sources/lib/walker/class.dylan b/sources/lib/walker/class.dylan index 83d14c4761..4988361b69 100644 --- a/sources/lib/walker/class.dylan +++ b/sources/lib/walker/class.dylan @@ -10,7 +10,7 @@ define constant = limited(, of: ); define constant - = limited(, of: ); + = limited(, of: , default-fill: 0); define inline function walker-slot-value (object, slot-descriptor :: ) => (value)