Update of /var/lib/cvs/src/common/common-dylan
In directory cantor:/tmp/cvs-serv16009/common/common-dylan
Modified Files:
Tag: GD_2_5
Makegen common-dylan-exports.dylan extensions.dylan
format.dylan fun-dev-compat.dylan locators-protocol.dylan
streams-protocol.dylan
Added Files:
Tag: GD_2_5
bootstrap-common-dylan-exports.dylan
bootstrap-common-dylan.lid
Log Message:
Bug: 7002
Merge the gd-2-3-newio branch, containing updates to use the IO and
System libraries from Functional Objects, and (in many cases) to use
the Common-Dylan API instead of Gwydion local extensions.
--- NEW FILE: bootstrap-common-dylan-exports.dylan ---
module: dylan-user
define library common-dylan
use dylan,
export: { dylan };
use table-extensions;
use random;
use transcendental,
import: { transcendental => transcendentals },
export: all;
export
common-dylan,
common-extensions,
streams-protocol,
locators-protocol,
simple-random,
simple-io,
byte-vector;
end library;
define module simple-io
create format-out;
end module;
define module simple-random
use random,
import: { <random-state> => <random>, random },
export: all;
end module;
define module byte-vector
use extensions,
export: {<byte>,
<byte-vector>};
end module;
define module common-extensions
use dylan;
use system, import: { copy-bytes }, export: { copy-bytes };
use extensions,
rename: {$not-supplied => $unsupplied,
on-exit => register-application-exit-function},
export: {$unsupplied,
integer-length,
false-or,
one-of,
<format-string-condition>,
ignore,
key-exists?,
register-application-exit-function,
<byte-character>};
use %Hash-Tables,
export: {remove-all-keys!};
use table-extensions,
export: {<string-table>};
create
<closable-object>,
close,
<stream>,
true?,
false?,
position,
split,
fill-table!,
find-element,
condition-to-string,
format-to-string;
export
/* Numerics */
//integer-length,
/* Unsupplied, unfound */
//$unsupplied,
supplied?,
unsupplied?,
unsupplied,
$unfound,
found?,
unfound?,
unfound,
/* Collections */
//<object-deque>,
//<stretchy-sequence>,
<stretchy-object-vector>,
//concatenate!,
//position,
//remove-all-keys!,
//difference,
//fill-table!,
//find-element,
//key-exists?,
/* Conditions */
//<format-string-condition>,
//condition-to-string,
/* Debugging */
//debug-message,
/* Types */
//false-or,
//one-of,
subclass,
/* Ignoring */
//ignore,
ignorable,
/* Converting to and from numbers */
//float-to-string
integer-to-string,
number-to-string,
string-to-integer;
//string-to-float,
/* Appliation runtime environment */
//application-name,
//application-filename,
//application-arguments,
//exit-application;
//register-exit-application-function,
#if (~mindy)
export
\table-definer,
\iterate,
\when;
export
\%iterate-aux, // ###
\%iterate-param-helper, // ###
\%iterate-value-helper; // ###
#endif
end module;
define module common-dylan
use dylan,
export: all;
use extensions,
import: { <general-integer> => <abstract-integer> },
export: all;
use common-extensions,
export: all;
end module;
define module locators-protocol
create <locator>;
create supports-open-locator?,
open-locator,
supports-list-locator?,
list-locator;
end module locators-protocol;
define module streams-protocol
// Conditions
create <stream-error>,
stream-error-stream,
<end-of-stream-error>,
<incomplete-read-error>,
stream-error-sequence,
stream-error-count,
<incomplete-write-error>,
stream-error-count;
// Opening streams
create open-file-stream;
// Reading from streams
create read-element,
unread-element,
peek,
read,
read-into!,
discard-input,
stream-input-available?,
stream-contents,
stream-contents-as;
// Writing to streams
create write-element,
write,
force-output,
wait-for-io-completion,
synchronize-output,
discard-output;
// Querying streams
create stream-open?,
stream-element-type,
stream-at-end?,
stream-size;
// Positioning streams
create <positionable-stream>,
stream-position,
stream-position-setter,
adjust-stream-position;
end module streams-protocol;
define module common-dylan-internals
use common-dylan;
use extensions;
use cheap-io, import: { puts => write-console };
use introspection, rename: { subclass-of => subclass-class };
use simple-io;
use locators-protocol;
use streams-protocol;
end module common-dylan-internals;
--- NEW FILE: bootstrap-common-dylan.lid ---
Library: common-dylan
Features: bootstrap
Unique-id-base: 5200
bootstrap-common-dylan-exports.dylan
extensions.dylan
common-extensions.dylan
format.dylan
locators-protocol.dylan
streams-protocol.dylan
Index: Makegen
===================================================================
RCS file: /var/lib/cvs/src/common/common-dylan/Makegen,v
retrieving revision 1.9.2.4
retrieving revision 1.9.2.5
diff -u -d -r1.9.2.4 -r1.9.2.5
--- Makegen 21 Jul 2004 21:50:37 -0000 1.9.2.4
+++ Makegen 22 Jul 2004 16:35:09 -0000 1.9.2.5
@@ -2,9 +2,8 @@
$D2CFLAGS # added by update-libdirs
= $d2c_runtime
- . ' -L../threads'
- . ' -L../streams'
. ' -L../table-ext'
+ . ' -L../threads'
. ' -L../../d2c/runtime/random';
$CPPFLAGS .= " -I$srcdir";
Index: common-dylan-exports.dylan
===================================================================
RCS file: /var/lib/cvs/src/common/common-dylan/common-dylan-exports.dylan,v
retrieving revision 1.12.2.5
retrieving revision 1.12.2.6
diff -u -d -r1.12.2.5 -r1.12.2.6
--- common-dylan-exports.dylan 18 Oct 2003 22:13:37 -0000 1.12.2.5
+++ common-dylan-exports.dylan 22 Jul 2004 16:35:13 -0000 1.12.2.6
@@ -6,7 +6,6 @@
use threads, export: { threads };
use melange-support;
- use streams;
use table-extensions;
use random;
use transcendental,
@@ -24,6 +23,7 @@
// simple-debugging,
simple-io,
byte-vector,
+ functional-objects-extras,
functional-extensions;
end library;
@@ -35,8 +35,9 @@
export
find-value;
export
- with-bounds-checks,
- without-bounds-checks;
+ element-range-check,
+ \with-bounds-checks,
+ \without-bounds-checks;
end module;
define module c-support
@@ -134,13 +135,14 @@
export: {<string-table>};
use transcendentals, import: { logn };
use c-support;
- use streams, import: { <stream> },
- export: {<stream>};
use simple-profiling,
export: { \profiling,
profiling-type-result };
create
+ <closable-object>,
+ close,
+ <stream>,
true?,
false?,
position,
@@ -240,6 +242,9 @@
end module locators-protocol;
define module streams-protocol
+ use common-extensions,
+ import: { <stream>, close },
+ export: all;
// Conditions
create <stream-error>,
stream-error-stream,
@@ -280,12 +285,24 @@
adjust-stream-position;
end module streams-protocol;
+define module functional-objects-extras
+ use common-extensions,
+ import: { <closable-object> },
+ export: all;
+ use cheap-io,
+ import: { puts => write-console },
+ export: all;
+ create <locator-defaults>,
+ <server-locator>,
+ <physical-locator>;
+end module functional-objects-extras;
+
define module common-dylan-internals
use common-dylan;
use extensions;
+ use functional-objects-extras;
use system, import: { copy-bytes => %copy-bytes, vector-elements-address };
use magic, import: { %element, %element-setter };
- use cheap-io, import: { puts => write-console };
use introspection, rename: { subclass-of => subclass-class };
use machine-words;
use melange-support;
Index: extensions.dylan
===================================================================
RCS file: /var/lib/cvs/src/common/common-dylan/extensions.dylan,v
retrieving revision 1.23.2.3
retrieving revision 1.23.2.4
diff -u -d -r1.23.2.3 -r1.23.2.4
--- extensions.dylan 14 Jun 2003 09:22:19 -0000 1.23.2.3
+++ extensions.dylan 22 Jul 2004 16:35:16 -0000 1.23.2.4
@@ -1,6 +1,5 @@
module: common-extensions
-
//=========================================================================
// Unsupplied, unfound.
//=========================================================================
@@ -44,6 +43,7 @@
end function unfound;
+#if (~bootstrap)
//=========================================================================
// Application environment functions.
//=========================================================================
@@ -81,6 +81,7 @@
exit(exit-code: exit-code);
end;
+#endif
//=========================================================================
// Ignore & ignorable
@@ -101,14 +102,14 @@
define constant $digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
define method integer-to-string
- (integer :: <integer>,
+ (integer :: <general-integer>,
#key base :: type-union(limited(<integer>, min: 2, max: 36)) = 10,
size: desired-size :: false-or(<integer>),
fill :: <character> = '0')
=> (string :: <byte-string>);
local
method collect
- (value :: <integer>, digits :: <list>, count :: <integer>)
+ (value :: <general-integer>, digits :: <list>, count :: <integer>)
=> (digits :: <list>, count :: <integer>);
let (quotient, remainder) = floor/(value, base);
let digits = pair($digits[as(<integer>, remainder)], digits);
@@ -122,12 +123,11 @@
let (digits, count) =
if (integer < 0)
// strip off last digit to avoid overflow in $minimum-integer case
- let (quotient :: <integer>, remainder :: <integer>)
- = truncate/(integer, base);
+ let (quotient, remainder) = truncate/(integer, base);
if (zero?(quotient))
- values(list($digits[- remainder]), 1);
+ values(list($digits[- as(<integer>, remainder)]), 1);
else
- collect(- quotient, list($digits[- remainder]), 1);
+ collect(- quotient, list($digits[- as(<integer>, remainder)]), 1);
end if;
else
collect(integer, #(), 0);
@@ -149,6 +149,7 @@
returned-string;
end method integer-to-string;
+#if (~bootstrap)
define constant $minimum-normalized-single-significand :: <extended-integer>
= ash(#e1, float-digits(1.0s0) - 1);
define constant $minimum-normalized-double-significand :: <extended-integer>
@@ -177,7 +178,7 @@
$minimum-normalized-extended-significand);
end method;
-define inline method float-to-string-aux
+define inline-only method float-to-string-aux
(v :: <float>,
minimum-exponent :: <integer>,
minimum-normalized-significand :: <extended-integer>)
@@ -332,17 +333,20 @@
end if;
as(<byte-string>, s);
end method;
+#endif
define open generic number-to-string
(number :: <number>) => (string :: <string>);
-define method number-to-string (integer :: <integer>) => (string :: <string>);
+define method number-to-string (integer :: <general-integer>) => (string ::
<string>);
integer-to-string(integer, base: 10);
end method number-to-string;
+#if (~bootstrap)
define method number-to-string (float :: <float>) => (string :: <string>);
float-to-string(float);
end method number-to-string;
+#endif
define method string-to-integer
(string :: <byte-string>,
@@ -452,79 +456,7 @@
end block;
end method string-to-integer;
-//=========================================================================
-// Macros
-//=========================================================================
-// Miscellaneous macros exported from common-extensions. These are not
-// available under Mindy.
-//
-// XXX - table-definer conses excessively. With more macrology, it could
-// run much faster.
-// XXX - can the name bound by 'iterate' return?
-
-#if (~mindy)
-
-define macro table-definer
- { define table ?:name ?eq:token { ?keys-and-values } }
- => { define constant ?name :: <table> ?eq make(<table>);
- fill-table!(?name, list(?keys-and-values)); }
- { define table ?:name :: ?type:expression ?eq:token { ?keys-and-values } }
- => { define constant ?name :: ?type ?eq make(?type);
- fill-table!(?name, list(?keys-and-values)); }
-keys-and-values:
- { ?key:expression => ?value:expression, ... } => { ?key, ?value, ... }
- { } => { }
-end macro;
-
-define macro iterate
- { iterate ?:name (?clauses:*) ?:body end }
- => { %iterate-aux ?name
- %iterate-param-helper(?clauses)
- %iterate-value-helper(?clauses)
- ?body
- end }
-end;
-
-define macro %iterate-aux
- { %iterate-aux ?:name
- ?param-clauses:macro
- ?value-clauses:macro
- ?:body
- end }
- => { local method ?name (?param-clauses)
- ?body
- end;
- ?name(?value-clauses) }
-end macro;
-
-define macro %iterate-param-helper
- { %iterate-param-helper(?clauses) }
- => { ?clauses }
-clauses:
- { ?:name :: ?type:*, ... }
- => { ?name :: ?type, ... }
- { ?:name :: ?type:* = ?value:*, ... }
- => { ?name :: ?type, ... }
- { } => { }
-end;
-
-define macro %iterate-value-helper
- { %iterate-value-helper(?clauses) }
- => { ?clauses }
-clauses:
- { ?:name :: ?type:*, ... }
- => { #f, ... }
- { ?:name :: ?type:* = ?value:*, ... }
- => { ?value, ... }
- { } => { }
-end;
-
-define macro when
- { when (?:expression) ?:body end }
- => { if (?expression) ?body end }
-end macro;
-
-#endif
+#if (~bootstrap)
define method string-to-float
(string :: <byte-string>,
#key _start :: <integer> = 0,
@@ -767,3 +699,93 @@
integer-part(_start, #f, #e0);
end if;
end method;
+#endif
+
+//=========================================================================
+// Macros
+//=========================================================================
+// Miscellaneous macros exported from common-extensions. These are not
+// available under Mindy.
+//
+// XXX - table-definer conses excessively. With more macrology, it could
+// run much faster.
+// XXX - can the name bound by 'iterate' return?
+
+#if (~mindy)
+
+define macro table-definer
+ { define table ?:name ?eq:token { ?keys-and-values } }
+ => { define constant ?name :: <table> ?eq make(<table>);
+ fill-table!(?name, list(?keys-and-values)); }
+ { define table ?:name :: ?type:expression ?eq:token { ?keys-and-values } }
+ => { define constant ?name :: ?type ?eq make(?type);
+ fill-table!(?name, list(?keys-and-values)); }
+keys-and-values:
+ { ?key:expression => ?value:expression, ... } => { ?key, ?value, ... }
+ { } => { }
+end macro;
+
+define macro iterate
+ { iterate ?:name (?clauses:*) ?:body end }
+ => { %iterate-aux ?name
+ %iterate-param-helper(?clauses)
+ %iterate-value-helper(?clauses)
+ ?body
+ end }
+end;
+
+define macro %iterate-aux
+ { %iterate-aux ?:name
+ ?param-clauses:macro
+ ?value-clauses:macro
+ ?:body
+ end }
+ => { local method ?name (?param-clauses)
+ ?body
+ end;
+ ?name(?value-clauses) }
+end macro;
+
+define macro %iterate-param-helper
+ { %iterate-param-helper(?clauses) }
+ => { ?clauses }
+clauses:
+ { ?:name :: ?type:*, ... }
+ => { ?name :: ?type, ... }
+ { ?:name :: ?type:* = ?value:*, ... }
+ => { ?name :: ?type, ... }
+ { } => { }
+end;
+
+define macro %iterate-value-helper
+ { %iterate-value-helper(?clauses) }
+ => { ?clauses }
+clauses:
+ { ?:name :: ?type:*, ... }
+ => { #f, ... }
+ { ?:name :: ?type:* = ?value:*, ... }
+ => { ?value, ... }
+ { } => { }
+end;
+
+define macro when
+ { when (?:expression) ?:body end }
+ => { if (?expression) ?body end }
+end macro;
+
+#endif
+
+//=========================================================================
+// Hacks for mindy
+//=========================================================================
+#if (mindy)
+
+define function subclass
+ (cls :: <class>)
+ => (subclass :: <type>);
+ limited(<class>, subclass-of: cls);
+end;
+
+define constant <stretchy-object-vector> = <stretchy-vector>;
+
+#endif
Index: format.dylan
===================================================================
RCS file: /var/lib/cvs/src/common/common-dylan/format.dylan,v
retrieving revision 1.1.2.2
retrieving revision 1.1.2.3
diff -u -d -r1.1.2.2 -r1.1.2.3
--- format.dylan 18 Oct 2003 22:13:37 -0000 1.1.2.2
+++ format.dylan 22 Jul 2004 16:35:16 -0000 1.1.2.3
@@ -186,7 +186,9 @@
<collection> => print-collection(buffer, object);
<boolean> => print-string(buffer, if (object) "#t" else "#f" end);
<integer> => print-string(buffer, integer-to-string(object));
+#if (~bootstrap)
<float> => print-string(buffer, float-to-string(object));
+#endif
<machine-word> => print-string(buffer, machine-word-to-string(object));
<method> => print-method(buffer, object);
otherwise => print-basic-name(buffer, object: object);
@@ -219,6 +221,7 @@
define method print-unique-name
(buffer :: <string-buffer>, union :: <union>) => ()
print-format(buffer, "{%s: ", object-class-name(union));
+#if (~mindy)
unless (empty?(union.union-singletons))
print-string(buffer, "one-of(");
for (object in union.union-singletons, first? = #t then #f)
@@ -232,6 +235,12 @@
unless (first?) print-string(buffer, ", ") end;
print-pretty-name(buffer, type);
end;
+#else
+ for(type in union.union-members, first? = #t then #f)
+ unless (first?) print-string(buffer, ", ") end;
+ print-pretty-name(buffer, type);
+ end;
+#endif
print-string(buffer, "}")
end method print-unique-name;
Index: fun-dev-compat.dylan
===================================================================
RCS file: /var/lib/cvs/src/common/common-dylan/fun-dev-compat.dylan,v
retrieving revision 1.15.2.1
retrieving revision 1.15.2.2
diff -u -d -r1.15.2.1 -r1.15.2.2
--- fun-dev-compat.dylan 14 Jun 2003 09:22:19 -0000 1.15.2.1
+++ fun-dev-compat.dylan 22 Jul 2004 16:35:16 -0000 1.15.2.2
@@ -9,6 +9,14 @@
// Utilities
//
+// element-range-check
+//
+define inline method element-range-check
+ (index :: <integer>, limit :: <integer>)
+ => (res :: <boolean>);
+ 0 <= index & index < limit;
+end method;
+
// without-bounds-checks
// Note: intentional violation of hygiene required
Index: locators-protocol.dylan
===================================================================
RCS file: /var/lib/cvs/src/common/common-dylan/locators-protocol.dylan,v
retrieving revision 1.2
retrieving revision 1.2.2.1
diff -u -d -r1.2 -r1.2.2.1
--- locators-protocol.dylan 10 Aug 2002 22:00:53 -0000 1.2
+++ locators-protocol.dylan 22 Jul 2004 16:35:16 -0000 1.2.2.1
@@ -15,11 +15,8 @@
define open abstract class <closable-object> (<object>)
end class <closable-object>;
-/* Defined in our streams library, which needs to be built
- without common-dylan for bootstapping. Clean up later.
define open abstract class <stream> (<closable-object>)
end class <stream>;
-*/
define open abstract class <locator-defaults> (<object>)
end class <locator-defaults>;
Index: streams-protocol.dylan
===================================================================
RCS file: /var/lib/cvs/src/common/common-dylan/streams-protocol.dylan,v
retrieving revision 1.1
retrieving revision 1.1.4.1
diff -u -d -r1.1 -r1.1.4.1
--- streams-protocol.dylan 20 Apr 2002 15:57:09 -0000 1.1
+++ streams-protocol.dylan 22 Jul 2004 16:35:16 -0000 1.1.4.1
@@ -16,7 +16,8 @@
// know about the new class too, it is simpler to rely on subclassing
// <format-string-condition>.
define method make
- (class :: subclass(<stream-error>),
+ (class :: subclass(<stream-error>),
+ #next next-method,
#rest args,
#key stream :: <stream>,
format-string,
@@ -36,7 +37,8 @@
end class <end-of-stream-error>;
define method make
- (class == <end-of-stream-error>, #key stream :: <stream>)
+ (class == <end-of-stream-error>, #next next-method,
+ #key stream :: <stream>)
=> (error :: <end-of-stream-error>)
next-method(class,
stream: stream,
@@ -131,24 +133,26 @@
#key start = 0, on-end-of-stream = unsupplied())
=> (count)
let limit = min(n + start, sequence.size);
- iterate loop (i = start)
- if (i < limit)
- let elt = read-element(stream, on-end-of-stream: unfound());
- if (found?(elt))
- sequence[i] := elt;
- loop(i + 1);
- elseif (supplied?(on-end-of-stream))
- i - start
+ local
+ method loop (i)
+ if (i < limit)
+ let elt = read-element(stream, on-end-of-stream: unfound());
+ if (found?(elt))
+ sequence[i] := elt;
+ loop(i + 1);
+ elseif (supplied?(on-end-of-stream))
+ i - start
+ else
+ signal(make(<incomplete-read-error>,
+ stream: stream,
+ count: i - start, // seems kinda redundant...
+ sequence: copy-sequence(sequence, start: start, end: i)))
+ end
else
- signal(make(<incomplete-read-error>,
- stream: stream,
- count: i - start, // seems kinda redundant...
- sequence: copy-sequence(sequence, start: start, end: i)))
- end
- else
- i - start
- end if;
- end;
+ i - start
+ end if;
+ end;
+ loop(start);
end method read-into!;
_______________________________________________
Gd-chatter mailing list
Gd-chatter@xxxxxxxxxxxxxxxx
http://www.gwydiondylan.org/mailman/listinfo/gd-chatter
|
