[Gd-chatter] r11757 - in trunk/fundev/sources: environment/dswank environment/property-pages environment/protocols environment/server/dummy environment/tools lib/cl registry/generic
andreas at gwydiondylan.org
andreas at gwydiondylan.org
Fri Mar 28 00:30:04 CET 2008
Author: andreas
Date: Fri Mar 28 00:30:03 2008
New Revision: 11757
Added:
trunk/fundev/sources/environment/protocols/utils.dylan (contents, props changed)
trunk/fundev/sources/environment/server/dummy/
trunk/fundev/sources/environment/server/dummy/Open-Source-License.txt (contents, props changed)
trunk/fundev/sources/environment/server/dummy/environment-server.dylan (contents, props changed)
trunk/fundev/sources/environment/server/dummy/environment-server.lid (contents, props changed)
trunk/fundev/sources/environment/server/dummy/library_module.dylan (contents, props changed)
trunk/fundev/sources/registry/generic/environment-server (contents, props changed)
Modified:
trunk/fundev/sources/environment/dswank/dswank-exports.dylan
trunk/fundev/sources/environment/dswank/dswank.dylan
trunk/fundev/sources/environment/property-pages/environment-object-properties.dylan
trunk/fundev/sources/environment/property-pages/module.dylan
trunk/fundev/sources/environment/property-pages/user-object-properties.dylan
trunk/fundev/sources/environment/protocols/environment-protocols.lid
trunk/fundev/sources/environment/protocols/library.dylan
trunk/fundev/sources/environment/protocols/loose-environment-protocols.lid
trunk/fundev/sources/environment/protocols/module.dylan
trunk/fundev/sources/environment/tools/describer.dylan
trunk/fundev/sources/environment/tools/module.dylan
trunk/fundev/sources/environment/tools/object-names.dylan
trunk/fundev/sources/lib/cl/cl-strings.dylan
Log:
job: fd
* Moved environment object description code from DUIM-dependent library
to environment-protocols.
* Implement describe command in dswank.
* More xref commands in dswank.
* dswank can now be used as an inferior Lisp with M-x slime
Modified: trunk/fundev/sources/environment/dswank/dswank-exports.dylan
==============================================================================
--- trunk/fundev/sources/environment/dswank/dswank-exports.dylan (original)
+++ trunk/fundev/sources/environment/dswank/dswank-exports.dylan Fri Mar 28 00:30:03 2008
@@ -13,6 +13,7 @@
use system;
use registry-projects;
use stack-walker;
+ use release-info;
end library;
define module dswank
@@ -32,4 +33,5 @@
use locators;
use registry-projects;
use stack-walker;
+ use release-info;
end module;
Modified: trunk/fundev/sources/environment/dswank/dswank.dylan
==============================================================================
--- trunk/fundev/sources/environment/dswank/dswank.dylan (original)
+++ trunk/fundev/sources/environment/dswank/dswank.dylan Fri Mar 28 00:30:03 2008
@@ -52,12 +52,13 @@
end;
define swank-function connection-info ()
- #(#":pid", 23,
- #":style", #":fd-handler",
- #":lisp-implementation", #(#":type", "dylan",
- #":name", "opendylan",
- #":version", "1.0beta5"),
- #":version", "2008-03-24");
+ list(#":pid", 23,
+ #":style", #":fd-handler",
+ #":lisp-implementation", list(#":type", "dylan",
+ #":name", release-product-name(),
+ #":version", release-version()),
+ #":version", "2008-03-24",
+ #":package", #(#":name", "opendylan", #":prompt", "opendylan"));
end;
define swank-function quit-lisp ()
@@ -140,8 +141,10 @@
res;
end;
-//define swank-function describe-symbol (symbol-name)
-//end;
+define swank-function describe-symbol (symbol-name)
+ let env = get-environment-object(symbol-name);
+ environment-object-description(*project*, env, *module*)
+end;
define function get-environment-object (symbol-name)
let library = #f;
@@ -179,15 +182,7 @@
if (location)
- let source-record = location.source-location-source-record;
- let source-name =
- select (source-record by instance?)
- <file-source-record> =>
- let location = source-record.source-record-location;
- file-exists?(location) & locator-as-string(<byte-string>, location);
- otherwise =>
- source-record.source-record-name;
- end;
+ let source-name = print-environment-object-location(*project*, env-obj);
let (name, lineno)
= source-line-location(location.source-location-source-record,
@@ -252,78 +247,53 @@
source-form-clients(*project*, env-obj);
end;
-define function print-function-parameters
- (server :: <server>, function-object :: <function-object>,
- namespace :: false-or(<namespace-object>))
- => (name :: <string>)
- with-output-to-string (stream)
- let <object>-class = find-environment-object(server, $<object>-id);
- let (required, rest, key, all-keys?, next) // ... values, rest-value)
- = function-parameters(server, function-object);
- format(stream, "(");
- local method do-parameter (parameter :: <parameter>) => ()
- let keyword
- = instance?(parameter, <optional-parameter>)
- & parameter.parameter-keyword;
- let type = parameter.parameter-type;
- if (keyword)
- format(stream, "%s: ", keyword)
- end;
- format(stream, "%s", parameter.parameter-name);
- unless (type == <object>-class)
- format(stream, " :: %s",
- environment-object-display-name(server, type, namespace)
- | "<?>")
- end
- end method do-parameter;
- local method do-parameters (parameters :: <parameters>) => ()
- for (parameter :: <parameter> in parameters,
- separator = "" then ", ")
- format(stream, separator);
- do-parameter(parameter)
- end for;
- end method do-parameters;
- do-parameters(required);
- let printed-something = size(required) > 0;
- local method print-separator () => ()
- if (printed-something)
- format(stream, ", ");
- else
- printed-something := #t;
- end;
- end method print-separator;
- if (next)
- print-separator();
- format(stream, "#next ");
- do-parameter(next);
- end;
- if (rest)
- print-separator();
- format(stream, "#rest ");
- do-parameter(rest);
- end;
- case
- key & size(key) > 0 =>
- print-separator();
- format(stream, "#key ");
- do-parameters(key);
- if (all-keys?)
- format(stream, ", #all-keys")
- end;
- all-keys? =>
- print-separator();
- format(stream, "#key, #all-keys");
- otherwise =>
- #f;
- end;
- format(stream, ")");
+define xref-function references (env-obj)
+ source-form-clients(*project*, env-obj);
+end;
+
+define xref-function sets (env-obj)
+ // FIXME: returns all references, needs to find actual setters
+ source-form-clients(*project*, env-obj);
+end;
+
+define xref-function binds (env-obj)
+ // FIXME: returns all references, needs to find actual setters
+ source-form-clients(*project*, env-obj);
+end;
+
+define xref-function macroexpands (env-obj)
+ macro-call-source-forms(*project*, env-obj);
+end;
+
+define xref-function specializes (function)
+ let generic
+ = select (function by instance?)
+ <generic-function-object> => function;
+ <method-object> => method-generic-function(*project*, function);
+ otherwise => #f;
+ end;
+ if (generic)
+ concatenate-as(<vector>,
+ vector(generic), generic-function-object-methods(*project*, generic));
+ else
+ #()
end
-end function print-function-parameters;
+end;
+
+define xref-function callers (env-obj)
+ source-form-clients(*project*, env-obj);
+end;
+
+define xref-function callees (env-obj)
+ // FIXME: filter for function definitions
+ source-form-used-definitions(*project*, env-obj);
+end;
define swank-function operator-arglist (symbol, package)
let env-obj = get-environment-object(symbol);
if (instance?(env-obj, <function-object>))
- print-function-parameters(*project*, env-obj, *module*)
+ concatenate(print-function-parameters(*project*, env-obj, *module*),
+ " => ", print-function-values(*project*, env-obj, *module*));
else
#"nil"
end;
@@ -338,11 +308,46 @@
format(stream, "%s%s", siz, s-expression);
end;
-define function main()
+define function main(args)
start-sockets();
- let socket = make(<server-socket>, port: 4005);
+ let tmpfile = #f;
+ let port = 4005;
+ unless (args.size >= 1 & args[0] = "--listen")
+ let line = read-line(*standard-input*);
+ let sexp = read-lisp(make(<string-stream>, direction: #"input", contents: line));
+ tmpfile :=
+ block(ret)
+ for (call in sexp.tail)
+ if (call.head == #"funcall")
+ if (call.tail.head.tail.head = "swank:start-server")
+ ret(call[2])
+ end;
+ end;
+ end;
+ error("error parsing swank startup command");
+ end;
+ end;
+ local method open ()
+ block ()
+ let socket = make(<server-socket>, port: port);
+ format(*standard-output*, "Waiting for connection on port %d\n", port);
+ if (tmpfile)
+ with-open-file (file = tmpfile, direction: #"output")
+ write(file, integer-to-string(port));
+ end;
+ end;
+ socket;
+ exception (e :: <error>)
+ port := port + 1;
+ open();
+ end;
+ end;
+ let socket = open();
let stream = accept(socket);
*server* := start-compiler(stream);
+ let greeting = concatenate("Welcome to dswank - the ", release-product-name(), " ",
+ release-version(), " SLIME interface");
+ write-to-emacs(stream, list(#":write-string", greeting));
while(#t)
let length = string-to-integer(read(stream, 6), base: 16);
let line = read(stream, length);
@@ -354,4 +359,4 @@
end;
end;
-main();
+main(application-arguments());
Modified: trunk/fundev/sources/environment/property-pages/environment-object-properties.dylan
==============================================================================
--- trunk/fundev/sources/environment/property-pages/environment-object-properties.dylan (original)
+++ trunk/fundev/sources/environment/property-pages/environment-object-properties.dylan Fri Mar 28 00:30:03 2008
@@ -10,8 +10,6 @@
/// Some useful constants (move into environment-tools?)
define constant $list-separator = ", ";
-define constant $not-applicable = "not applicable";
-define constant $not-available = "not available";
/// Environment object property pages
@@ -187,7 +185,7 @@
end if;
if (member?(#"source-location", property-types))
let source-location
- = print-environment-object-location(project, environment-object, module);
+ = print-environment-object-location(project, environment-object);
add-label-and-value("Source:", source-location)
end if;
if (member?(#"defined-in", property-types))
@@ -377,153 +375,6 @@
end method print-application-object-address;
-/// Counting contents
-
-define generic environment-object-content-counts
- (project :: <project-object>, environment-object :: <environment-object>)
- => (count :: false-or(<integer>), #rest more-counts :: <integer>);
-
-define method environment-object-content-counts
- (project :: <project-object>, project-object :: <project-object>)
- => (count :: false-or(<integer>), #rest more-counts :: <integer>)
- let library = project-library(project-object);
- if (library)
- let library-count = 1;
- let module-count :: <integer> = 0;
- let name-count :: <integer> = 0;
- let (library-module-count, library-name-count)
- = environment-object-content-counts(project-object, library);
- module-count := module-count + library-module-count;
- name-count := name-count + library-name-count;
- values(library-count, module-count, name-count)
- end
-end method environment-object-content-counts;
-
-define method environment-object-content-counts
- (project :: <project-object>, library-object :: <library-object>)
- => (count :: <integer>, #rest more-counts :: <integer>)
- let module-count :: <integer> = 0;
- let name-count :: <integer> = 0;
- local method do-module (m :: <module-object>) => ()
- module-count := module-count + 1;
- let module-name-count
- = environment-object-content-counts(project, m);
- name-count := name-count + module-name-count;
- end method do-module;
- do-library-modules(do-module, project, library-object, imported?: #f);
- values(module-count, name-count)
-end method environment-object-content-counts;
-
-define method environment-object-content-counts
- (project :: <project-object>, module-object :: <module-object>)
- => (count :: <integer>, #rest more-counts :: <integer>)
- let macro-count :: <integer> = 0;
- let class-count :: <integer> = 0;
- let constant-count :: <integer> = 0;
- let variable-count :: <integer> = 0;
- let gf-count :: <integer> = 0;
- let method-count :: <integer> = 0;
- let domain-count :: <integer> = 0;
- local
- method do-definition (definition :: <definition-object>) => ()
- select (definition by instance?)
- <macro-object> => macro-count := macro-count + 1;
- <class-object> => class-count := class-count + 1;
- <constant-object> => constant-count := constant-count + 1;
- <variable-object> => variable-count := variable-count + 1;
- <generic-function-object> => gf-count := gf-count + 1;
- <method-object> => method-count := method-count + 1;
- <domain-object> => domain-count := domain-count + 1;
- <environment-object> =>
- debug-message("Unexpected definition %= when counting -- ignored",
- definition);
- end
- end method do-definition;
-
- do-module-definitions(do-definition, project, module-object);
- values(macro-count,
- class-count,
- constant-count,
- variable-count,
- gf-count,
- method-count,
- domain-count)
-end method environment-object-content-counts;
-
-define method environment-object-content-counts
- (project :: <project-object>,
- generic-function-object :: <generic-function-object>)
- => (count :: <integer>, #rest more-counts :: <integer>)
- let method-count :: <integer> = 0;
- local method do-method (m :: <method-object>) => ()
- ignore(m);
- method-count := method-count + 1;
- end method do-method;
- do-generic-function-methods(do-method, project, generic-function-object);
- method-count
-end method environment-object-content-counts;
-
-define method environment-object-content-counts
- (project :: <project-object>, class-object :: <class-object>)
- => (count :: <integer>, #rest more-counts :: <integer>)
- let slot-count :: <integer> = 0;
- local method do-slot (s :: <slot-object>) => ()
- ignore(s);
- slot-count := slot-count + 1;
- end method do-slot;
- do-direct-slots(do-slot, project, class-object);
- slot-count
-end method environment-object-content-counts;
-
-define method environment-object-content-counts
- (project :: <project-object>, composite-object :: <composite-object>)
- => (count :: false-or(<integer>), #rest more-counts :: <integer>)
- composite-object-size(project, composite-object)
-end method environment-object-content-counts;
-
-define method environment-object-content-counts
- (project :: <project-object>, collection-object :: <collection-object>)
- => (count :: false-or(<integer>), #rest more-counts :: <integer>)
- collection-size(project, collection-object)
-end method environment-object-content-counts;
-
-
-/// Generate contents strings
-
-// Return a string describing a content type.
-
-define function content-type-name
- (content-type :: <symbol>) => (string :: <string>)
- select (content-type)
- #"library" => "library";
- #"module" => "module";
- #"name" => "name";
- #"definition" => "definition";
- #"unbound" => "unbound name";
- #"element" => "element";
- #"macro" => "macro";
- #"class" => "class";
- #"slot" => "slot";
- #"variable" => "variable";
- #"constant" => "constant";
- #"generic-function" => "generic function";
- #"method" => "method";
- #"domain" => "domain";
- end
-end function content-type-name;
-
-
-// Return a string describing a number of content items.
-
-define function print-content-count
- (stream :: <stream>, count :: <integer>, content-type :: <symbol>)
- => ()
- format(stream, "%d %s",
- count,
- string-pluralize(content-type-name(content-type), count: count))
-end function print-content-count;
-
-
/// environment-object-kind
define method environment-object-kind-label
@@ -588,143 +439,3 @@
end
end method environment-object-kind-label;
-
-/// print-environment-object-contents
-//
-// Return a string describing the contents of an environment object.
-
-define sideways method environment-object-contents
- (project :: <project-object>, object :: <environment-object>)
- => (contents :: <string>)
- let contents
- = with-output-to-string (stream)
- print-environment-object-contents(stream, project, object)
- end;
- if (empty?(contents))
- $not-available
- else
- contents
- end
-end method environment-object-contents;
-
-define generic print-environment-object-contents
- (stream :: <stream>, project :: <project-object>,
- object :: <environment-object>)
- => ();
-
-define method print-environment-object-contents
- (stream :: <stream>, project :: <project-object>,
- environment-object :: <environment-object>)
- => ()
- write(stream, $not-applicable)
-end method print-environment-object-contents;
-
-define method print-environment-object-contents
- (stream :: <stream>, project :: <project-object>,
- project-object :: <project-object>)
- => ()
- let (library-count, module-count, name-count)
- = environment-object-content-counts(project, project-object);
- ignore(library-count);
- if (library-count)
- print-content-count(stream, module-count, #"module");
- write(stream, $list-separator);
- print-content-count(stream, name-count, #"name")
- end
-end method print-environment-object-contents;
-
-define method print-environment-object-contents
- (stream :: <stream>, project :: <project-object>,
- library-object :: <library-object>)
- => ()
- let (module-count, name-count)
- = environment-object-content-counts(project, library-object);
- if (module-count)
- print-content-count(stream, module-count, #"module");
- write(stream, $list-separator);
- print-content-count(stream, name-count, #"name")
- end
-end method print-environment-object-contents;
-
-define method print-environment-object-contents
- (stream :: <stream>, project :: <project-object>,
- module-object :: <module-object>)
- => ()
- let need-separator? :: <boolean> = #f;
- local method maybe-print-content-count
- (stream :: <stream>, count :: <integer>, content-type :: <symbol>,
- #key prefix, suffix) => ()
- if (count > 0)
- if (need-separator?)
- write(stream, $list-separator)
- end;
- if (prefix) write(stream, prefix) end;
- print-content-count(stream, count, content-type);
- if (suffix) write(stream, suffix) end;
- need-separator? := #t
- end
- end method maybe-print-content-count;
- let (macro-count,
- class-count,
- constant-count,
- variable-count,
- gf-count,
- method-count,
- domain-count)
- = environment-object-content-counts(project, module-object);
- if (macro-count)
- let total-count :: <integer>
- = macro-count + class-count + constant-count + variable-count
- + gf-count + method-count + domain-count;
- if (total-count == 0)
- print-content-count(stream, total-count, #"definition")
- else
- maybe-print-content-count(stream, macro-count, #"macro");
- maybe-print-content-count(stream, class-count, #"class");
- maybe-print-content-count(stream, constant-count, #"constant");
- maybe-print-content-count(stream, variable-count, #"variable");
- maybe-print-content-count(stream, gf-count, #"generic-function");
- maybe-print-content-count(stream, method-count, #"method");
- maybe-print-content-count(stream, domain-count, #"domain");
- write(stream, " (");
- print-content-count(stream, total-count, #"definition");
- write(stream, " total)")
- end
- end
-end method print-environment-object-contents;
-
-define method print-environment-object-contents
- (stream :: <stream>, project :: <project-object>,
- generic-function-object :: <generic-function-object>)
- => ()
- let method-count
- = environment-object-content-counts(project, generic-function-object);
- method-count & print-content-count(stream, method-count, #"method")
-end method print-environment-object-contents;
-
-define method print-environment-object-contents
- (stream :: <stream>, project :: <project-object>,
- class-object :: <class-object>)
- => ()
- let slot-count = environment-object-content-counts(project, class-object);
- slot-count & print-content-count(stream, slot-count, #"slot")
-end method print-environment-object-contents;
-
-define method print-environment-object-contents
- (stream :: <stream>, project :: <project-object>,
- collection-object :: <collection-object>)
- => ()
- let element-count
- = environment-object-content-counts(project, collection-object);
- element-count & print-content-count(stream, element-count, #"element")
-end method print-environment-object-contents;
-
-define method print-environment-object-contents
- (stream :: <stream>, project :: <project-object>,
- user-object :: <user-object>)
- => ()
- let slot-count
- = show-slot-information?(user-object)
- & environment-object-content-counts(project, user-object);
- slot-count & print-content-count(stream, slot-count, #"slot")
-end method print-environment-object-contents;
Modified: trunk/fundev/sources/environment/property-pages/module.dylan
==============================================================================
--- trunk/fundev/sources/environment/property-pages/module.dylan (original)
+++ trunk/fundev/sources/environment/property-pages/module.dylan Fri Mar 28 00:30:03 2008
@@ -16,7 +16,7 @@
use environment-protocols;
use duim-internals,
- exclude: { position,
+ exclude: { position, string-pluralize,
get-property,
\put-property!, do-put-property!,
\remove-property!, do-remove-property!,
Modified: trunk/fundev/sources/environment/property-pages/user-object-properties.dylan
==============================================================================
--- trunk/fundev/sources/environment/property-pages/user-object-properties.dylan (original)
+++ trunk/fundev/sources/environment/property-pages/user-object-properties.dylan Fri Mar 28 00:30:03 2008
@@ -9,47 +9,16 @@
/// User object property pages
-define method show-slot-information?
- (class :: subclass(<user-object>)) => (show-information? :: <boolean>)
- #t
-end method show-slot-information?;
-
-define method show-slot-information?
- (class :: subclass(<internal-object>)) => (show-information? :: <boolean>)
- //---*** Maybe should make this a setting
- select (release-edition-type())
- #"emulator" => #t;
- #"internal" => #t;
- otherwise => #f;
- end
-end method show-slot-information?;
-
-define method show-slot-information?
- (object :: <user-object>) => (show-information? :: <boolean>)
- show-slot-information?(object-class(object))
-end method show-slot-information?;
-
define sideways method frame-property-types
(frame :: <environment-frame>, class :: subclass(<user-object>))
=> (types :: <list>)
- if (show-slot-information?(class))
- concatenate(next-method(), #(#"contents"))
- else
- next-method()
- end
+ concatenate(next-method(), #(#"contents"))
end method frame-property-types;
define sideways method frame-default-property-type
(frame :: <environment-frame>, class :: subclass(<user-object>))
=> (type :: false-or(<symbol>))
- //--- This is a little odd. We want the default page to be consistent
- //--- for internal and non-internal releases, so don't make internal
- //--- objects have the contents page as their default.
- if (show-slot-information?(class) & ~subtype?(class, <internal-object>))
- #"contents"
- else
- next-method()
- end
+ #"contents"
end method frame-default-property-type;
Modified: trunk/fundev/sources/environment/protocols/environment-protocols.lid
==============================================================================
--- trunk/fundev/sources/environment/protocols/environment-protocols.lid (original)
+++ trunk/fundev/sources/environment/protocols/environment-protocols.lid Fri Mar 28 00:30:03 2008
@@ -49,6 +49,7 @@
profiling
naming
channels
+ utils
Major-version: 2
Minor-version: 1
Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
Modified: trunk/fundev/sources/environment/protocols/library.dylan
==============================================================================
--- trunk/fundev/sources/environment/protocols/library.dylan (original)
+++ trunk/fundev/sources/environment/protocols/library.dylan Fri Mar 28 00:30:03 2008
@@ -17,6 +17,7 @@
use release-info;
use collections;
use memory-manager;
+ use cl, import: { cl-strings };
export environment-protocols;
export environment-imports;
Modified: trunk/fundev/sources/environment/protocols/loose-environment-protocols.lid
==============================================================================
--- trunk/fundev/sources/environment/protocols/loose-environment-protocols.lid (original)
+++ trunk/fundev/sources/environment/protocols/loose-environment-protocols.lid Fri Mar 28 00:30:03 2008
@@ -40,6 +40,7 @@
code-execution
naming
channels
+ utils
Major-version: 2
Minor-version: 1
Compilation-Mode: incremental
Modified: trunk/fundev/sources/environment/protocols/module.dylan
==============================================================================
--- trunk/fundev/sources/environment/protocols/module.dylan (original)
+++ trunk/fundev/sources/environment/protocols/module.dylan Fri Mar 28 00:30:03 2008
@@ -45,6 +45,7 @@
use source-records, export: all;
use file-source-records, export: all;
use release-info, export: all;
+ use cl-strings, import: { string-pluralize }, export: { string-pluralize };
end module environment-imports;
define module environment-protocols
@@ -768,4 +769,21 @@
export print-source-location,
application-state-label,
thread-state-label;
+
+ export environment-object-contents,
+ environment-object-description,
+ print-function-parameters,
+ print-function-values,
+ print-environment-object-location;
+
+
+ export $n/a,
+ $type-n/a,
+ $no-information-available,
+ $unknown-name,
+ $unknown,
+ $project-not-built,
+ $interactive-definition,
+ $not-available,
+ $not-applicable;
end module environment-protocols;
Added: trunk/fundev/sources/environment/protocols/utils.dylan
==============================================================================
--- (empty file)
+++ trunk/fundev/sources/environment/protocols/utils.dylan Fri Mar 28 00:30:03 2008
@@ -0,0 +1,633 @@
+module: environment-protocols
+
+
+define constant $n/a = "n/a";
+define constant $type-n/a = "<?>";
+define constant $no-information-available = "No information available";
+define constant $unknown-name = "{unknown-name}";
+define constant $project-not-built = "[project not built]";
+define constant $interactive-definition = "interactive definition";
+define constant $not-applicable = "not applicable";
+define constant $not-available = "not available";
+
+
+
+// Describer-specific methods
+
+define generic environment-object-description
+ (project :: <project-object>,
+ object :: <environment-object>, module :: <module-object>)
+ => (description :: <string>);
+
+define generic environment-object-contents
+ (project :: <project-object>, environment-object :: <environment-object>)
+ => (contents :: <string>);
+
+define method environment-object-description
+ (project :: <project-object>,
+ object :: <environment-object>, module :: <module-object>)
+ => (description :: <string>)
+ environment-object-unique-name(project, object, module, qualify-names?: #t)
+end method environment-object-description;
+
+define method environment-object-description
+ (project :: <project-object>,
+ object :: <definition-object>, module :: <module-object>)
+ => (description :: <string>)
+ let home-name
+ = environment-object-home-name(project, object);
+ if (instance?(home-name, <binding-name-object>))
+ let name = environment-object-primitive-name(project, home-name);
+ let home-module = name-namespace(project, home-name);
+ let home-library = environment-object-library(project, home-module);
+ let module-name = environment-object-primitive-name(project, home-module);
+ let library-name = environment-object-primitive-name(project, home-library);
+ let location = print-environment-object-location(project, object);
+ let type-name = environment-object-type-name(object);
+ concatenate
+ (// The "Name:" is in the title bar.
+ "In module ", module-name,
+ ", library ", library-name,
+ ", from file ", location, ":\n",
+ type-name, " ", name)
+ else
+ environment-object-unique-name
+ (project, object, module, qualify-names?: #t)
+ end
+end method environment-object-description;
+
+define method environment-object-description
+ (project :: <project-object>,
+ object :: <user-object>, module :: <module-object>)
+ => (description :: <string>)
+ if (instance?(object, <definition-object>))
+ next-method()
+ else
+ let class = application-object-class(project, object);
+ concatenate
+ (format-to-string
+ ("Object %s:\n",
+ environment-object-unique-name
+ (project, object, module, qualify-names?: #t)),
+ if (class)
+ environment-object-description(project, class, module)
+ else
+ #[]
+ end)
+ end
+end method environment-object-description;
+
+define method environment-object-description
+ (project :: <project-object>,
+ object :: <collection-object>, module :: <module-object>)
+ => (description :: <string>)
+ let size = collection-size(project, object);
+ concatenate
+ (format-to-string
+ ("Collection %s:\n",
+ environment-object-unique-name
+ (project, object, module, qualify-names?: #t)),
+ format-to-string("Size: %s\n", size | ""))
+end method environment-object-description;
+
+define macro environment-object-description-method-definer
+ { define environment-object-description-method ( ?class:name )
+ ?:body
+ end }
+ => { define method environment-object-description
+ (?=project :: <project-object>,
+ ?=object :: ?class, ?=module :: <module-object>,
+ #next next-method)
+ => (description :: <string>)
+ concatenate(next-method(), begin ?body end | "")
+ end method environment-object-description }
+end macro environment-object-description-method-definer;
+
+define function names->name-list
+ (names :: <sequence> /* of: <string> */)
+ => (name-list :: <string>)
+ concatenate
+ ("(",
+ select (names.size)
+ 0 => "";
+ 1 => names[0];
+ otherwise =>
+ reduce1
+ (method (names-so-far, new-name)
+ concatenate(names-so-far, ", ", new-name)
+ end,
+ names);
+ end,
+ ")")
+end function names->name-list;
+
+define environment-object-description-method (<class-object>)
+ // ---*** Can we show init-keywords, including those accepted by make
+ // and initialize methods?
+ let superclass-names :: <sequence>
+ = map(method (class-object)
+ environment-object-display-name(project, class-object, module)
+ end,
+ class-direct-superclasses(project, object));
+ names->name-list(superclass-names)
+end environment-object-description-method;
+
+define environment-object-description-method (<domain-object>)
+ let specializers = domain-specializers(project, object);
+ names->name-list(specializers)
+end environment-object-description-method;
+
+// Covers "define {generic,method,function}".
+define environment-object-description-method (<dylan-function-object>)
+ // ---*** Can we, for <generic-function-object>s, show all keywords
+ // accepted by all methods (of those defined at compile-time)?
+ // ---*** For make and initialize, can we show keyword parameters from
+ // slots descriptions for the relevant class?
+ concatenate
+ ("\n ",
+ print-function-parameters(project, object, module),
+ "\n => ",
+ print-function-values(project, object, module))
+end environment-object-description-method;
+
+define environment-object-description-method (<library-object>)
+ concatenate
+ ("\nContents:\t",
+ environment-object-contents(project, object));
+end environment-object-description-method;
+
+define environment-object-description-method (<macro-object>)
+ // ---*** Would like the lhs of the first main rule.
+end environment-object-description-method;
+
+define environment-object-description-method (<module-object>)
+ concatenate
+ ("\nContents:\t",
+ environment-object-contents(project, object));
+end environment-object-description-method;
+
+define environment-object-description-method (<module-variable-object>)
+ let type = variable-type(project, object);
+ concatenate
+ (" :: ",
+ if (type)
+ environment-object-display-name(project, type, module)
+ else
+ $unknown
+ end)
+end environment-object-description-method;
+
+define environment-object-description-method (<constant-object>)
+ let type = variable-type(project, object);
+ concatenate
+ (" :: ",
+ if (type)
+ environment-object-display-name(project, type, module)
+ else
+ $unknown
+ end)
+end environment-object-description-method;
+
+
+/// Counting contents
+
+define generic environment-object-content-counts
+ (project :: <project-object>, environment-object :: <environment-object>)
+ => (count :: false-or(<integer>), #rest more-counts :: <integer>);
+
+define method environment-object-content-counts
+ (project :: <project-object>, project-object :: <project-object>)
+ => (count :: false-or(<integer>), #rest more-counts :: <integer>)
+ let library = project-library(project-object);
+ if (library)
+ let library-count = 1;
+ let module-count :: <integer> = 0;
+ let name-count :: <integer> = 0;
+ let (library-module-count, library-name-count)
+ = environment-object-content-counts(project-object, library);
+ module-count := module-count + library-module-count;
+ name-count := name-count + library-name-count;
+ values(library-count, module-count, name-count)
+ end
+end method environment-object-content-counts;
+
+define method environment-object-content-counts
+ (project :: <project-object>, library-object :: <library-object>)
+ => (count :: <integer>, #rest more-counts :: <integer>)
+ let module-count :: <integer> = 0;
+ let name-count :: <integer> = 0;
+ local method do-module (m :: <module-object>) => ()
+ module-count := module-count + 1;
+ let module-name-count
+ = environment-object-content-counts(project, m);
+ name-count := name-count + module-name-count;
+ end method do-module;
+ do-library-modules(do-module, project, library-object, imported?: #f);
+ values(module-count, name-count)
+end method environment-object-content-counts;
+
+define method environment-object-content-counts
+ (project :: <project-object>, module-object :: <module-object>)
+ => (count :: <integer>, #rest more-counts :: <integer>)
+ let macro-count :: <integer> = 0;
+ let class-count :: <integer> = 0;
+ let constant-count :: <integer> = 0;
+ let variable-count :: <integer> = 0;
+ let gf-count :: <integer> = 0;
+ let method-count :: <integer> = 0;
+ let domain-count :: <integer> = 0;
+ local
+ method do-definition (definition :: <definition-object>) => ()
+ select (definition by instance?)
+ <macro-object> => macro-count := macro-count + 1;
+ <class-object> => class-count := class-count + 1;
+ <constant-object> => constant-count := constant-count + 1;
+ <variable-object> => variable-count := variable-count + 1;
+ <generic-function-object> => gf-count := gf-count + 1;
+ <method-object> => method-count := method-count + 1;
+ <domain-object> => domain-count := domain-count + 1;
+ <environment-object> =>
+ debug-message("Unexpected definition %= when counting -- ignored",
+ definition);
+ end
+ end method do-definition;
+
+ do-module-definitions(do-definition, project, module-object);
+ values(macro-count,
+ class-count,
+ constant-count,
+ variable-count,
+ gf-count,
+ method-count,
+ domain-count)
+end method environment-object-content-counts;
+
+define method environment-object-content-counts
+ (project :: <project-object>,
+ generic-function-object :: <generic-function-object>)
+ => (count :: <integer>, #rest more-counts :: <integer>)
+ let method-count :: <integer> = 0;
+ local method do-method (m :: <method-object>) => ()
+ ignore(m);
+ method-count := method-count + 1;
+ end method do-method;
+ do-generic-function-methods(do-method, project, generic-function-object);
+ method-count
+end method environment-object-content-counts;
+
+define method environment-object-content-counts
+ (project :: <project-object>, class-object :: <class-object>)
+ => (count :: <integer>, #rest more-counts :: <integer>)
+ let slot-count :: <integer> = 0;
+ local method do-slot (s :: <slot-object>) => ()
+ ignore(s);
+ slot-count := slot-count + 1;
+ end method do-slot;
+ do-direct-slots(do-slot, project, class-object);
+ slot-count
+end method environment-object-content-counts;
+
+define method environment-object-content-counts
+ (project :: <project-object>, composite-object :: <composite-object>)
+ => (count :: false-or(<integer>), #rest more-counts :: <integer>)
+ composite-object-size(project, composite-object)
+end method environment-object-content-counts;
+
+define method environment-object-content-counts
+ (project :: <project-object>, collection-object :: <collection-object>)
+ => (count :: false-or(<integer>), #rest more-counts :: <integer>)
+ collection-size(project, collection-object)
+end method environment-object-content-counts;
+
+
+/// Generate contents strings
+
+// Return a string describing a content type.
+
+define function content-type-name
+ (content-type :: <symbol>) => (string :: <string>)
+ select (content-type)
+ #"library" => "library";
+ #"module" => "module";
+ #"name" => "name";
+ #"definition" => "definition";
+ #"unbound" => "unbound name";
+ #"element" => "element";
+ #"macro" => "macro";
+ #"class" => "class";
+ #"slot" => "slot";
+ #"variable" => "variable";
+ #"constant" => "constant";
+ #"generic-function" => "generic function";
+ #"method" => "method";
+ #"domain" => "domain";
+ end
+end function content-type-name;
+
+
+// Return a string describing a number of content items.
+
+define function print-content-count
+ (stream :: <stream>, count :: <integer>, content-type :: <symbol>)
+ => ()
+ format(stream, "%d %s",
+ count,
+ string-pluralize(content-type-name(content-type), count: count))
+end function print-content-count;
+
+
+/// print-environment-object-contents
+//
+// Return a string describing the contents of an environment object.
+
+define method environment-object-contents
+ (project :: <project-object>, object :: <environment-object>)
+ => (contents :: <string>)
+ let contents
+ = with-output-to-string (stream)
+ print-environment-object-contents(stream, project, object)
+ end;
+ if (empty?(contents))
+ $not-available
+ else
+ contents
+ end
+end method environment-object-contents;
+
+define generic print-environment-object-contents
+ (stream :: <stream>, project :: <project-object>,
+ object :: <environment-object>)
+ => ();
+
+define method print-environment-object-contents
+ (stream :: <stream>, project :: <project-object>,
+ environment-object :: <environment-object>)
+ => ()
+ write(stream, $not-applicable)
+end method print-environment-object-contents;
+
+define method print-environment-object-contents
+ (stream :: <stream>, project :: <project-object>,
+ project-object :: <project-object>)
+ => ()
+ let (library-count, module-count, name-count)
+ = environment-object-content-counts(project, project-object);
+ ignore(library-count);
+ if (library-count)
+ print-content-count(stream, module-count, #"module");
+ write(stream, $list-separator);
+ print-content-count(stream, name-count, #"name")
+ end
+end method print-environment-object-contents;
+
+define method print-environment-object-contents
+ (stream :: <stream>, project :: <project-object>,
+ library-object :: <library-object>)
+ => ()
+ let (module-count, name-count)
+ = environment-object-content-counts(project, library-object);
+ if (module-count)
+ print-content-count(stream, module-count, #"module");
+ write(stream, $list-separator);
+ print-content-count(stream, name-count, #"name")
+ end
+end method print-environment-object-contents;
+
+define method print-environment-object-contents
+ (stream :: <stream>, project :: <project-object>,
+ module-object :: <module-object>)
+ => ()
+ let need-separator? :: <boolean> = #f;
+ local method maybe-print-content-count
+ (stream :: <stream>, count :: <integer>, content-type :: <symbol>,
+ #key prefix, suffix) => ()
+ if (count > 0)
+ if (need-separator?)
+ write(stream, $list-separator)
+ end;
+ if (prefix) write(stream, prefix) end;
+ print-content-count(stream, count, content-type);
+ if (suffix) write(stream, suffix) end;
+ need-separator? := #t
+ end
+ end method maybe-print-content-count;
+ let (macro-count,
+ class-count,
+ constant-count,
+ variable-count,
+ gf-count,
+ method-count,
+ domain-count)
+ = environment-object-content-counts(project, module-object);
+ if (macro-count)
+ let total-count :: <integer>
+ = macro-count + class-count + constant-count + variable-count
+ + gf-count + method-count + domain-count;
+ if (total-count == 0)
+ print-content-count(stream, total-count, #"definition")
+ else
+ maybe-print-content-count(stream, macro-count, #"macro");
+ maybe-print-content-count(stream, class-count, #"class");
+ maybe-print-content-count(stream, constant-count, #"constant");
+ maybe-print-content-count(stream, variable-count, #"variable");
+ maybe-print-content-count(stream, gf-count, #"generic-function");
+ maybe-print-content-count(stream, method-count, #"method");
+ maybe-print-content-count(stream, domain-count, #"domain");
+ write(stream, " (");
+ print-content-count(stream, total-count, #"definition");
+ write(stream, " total)")
+ end
+ end
+end method print-environment-object-contents;
+
+define method print-environment-object-contents
+ (stream :: <stream>, project :: <project-object>,
+ generic-function-object :: <generic-function-object>)
+ => ()
+ let method-count
+ = environment-object-content-counts(project, generic-function-object);
+ method-count & print-content-count(stream, method-count, #"method")
+end method print-environment-object-contents;
+
+define method print-environment-object-contents
+ (stream :: <stream>, project :: <project-object>,
+ class-object :: <class-object>)
+ => ()
+ let slot-count = environment-object-content-counts(project, class-object);
+ slot-count & print-content-count(stream, slot-count, #"slot")
+end method print-environment-object-contents;
+
+define method print-environment-object-contents
+ (stream :: <stream>, project :: <project-object>,
+ collection-object :: <collection-object>)
+ => ()
+ let element-count
+ = environment-object-content-counts(project, collection-object);
+ element-count & print-content-count(stream, element-count, #"element")
+end method print-environment-object-contents;
+
+define method print-environment-object-contents
+ (stream :: <stream>, project :: <project-object>,
+ user-object :: <user-object>)
+ => ()
+ let slot-count
+ = environment-object-content-counts(project, user-object);
+ slot-count & print-content-count(stream, slot-count, #"slot")
+end method print-environment-object-contents;
+
+/// Function names
+
+define constant $show-keyword-function-names = #f;
+
+// Create a user-visible string to describe function parameters
+define function print-function-parameters
+ (server :: <server>, function-object :: <function-object>,
+ namespace :: false-or(<namespace-object>))
+ => (name :: <string>)
+ with-output-to-string (stream)
+ let <object>-class = find-environment-object(server, $<object>-id);
+ let (required, rest, key, all-keys?, next) // ... values, rest-value)
+ = function-parameters(server, function-object);
+ format(stream, "(");
+ local method do-parameter (parameter :: <parameter>) => ()
+ let keyword
+ = instance?(parameter, <optional-parameter>)
+ & parameter.parameter-keyword;
+ let type = parameter.parameter-type;
+ if ($show-keyword-function-names)
+ if (keyword)
+ format(stream, "%s: ", keyword)
+ end;
+ format(stream, "%s", parameter.parameter-name);
+ else
+ format(stream, "%s", keyword | parameter.parameter-name)
+ end;
+ unless (type == <object>-class)
+ format(stream, " :: %s",
+ environment-object-display-name(server, type, namespace)
+ | $type-n/a)
+ end
+ end method do-parameter;
+ local method do-parameters (parameters :: <parameters>) => ()
+ for (parameter :: <parameter> in parameters,
+ separator = "" then ", ")
+ format(stream, separator);
+ do-parameter(parameter)
+ end for;
+ end method do-parameters;
+ do-parameters(required);
+ let printed-something = size(required) > 0;
+ local method print-separator () => ()
+ if (printed-something)
+ format(stream, ", ");
+ else
+ printed-something := #t;
+ end;
+ end method print-separator;
+ if (next)
+ print-separator();
+ format(stream, "#next ");
+ do-parameter(next);
+ end;
+ if (rest)
+ print-separator();
+ format(stream, "#rest ");
+ do-parameter(rest);
+ end;
+ case
+ key & size(key) > 0 =>
+ print-separator();
+ format(stream, "#key ");
+ do-parameters(key);
+ if (all-keys?)
+ format(stream, ", #all-keys")
+ end;
+ all-keys? =>
+ print-separator();
+ format(stream, "#key, #all-keys");
+ otherwise =>
+ #f;
+ end;
+ format(stream, ")");
+ end
+end function print-function-parameters;
+
+// Create a user-visible string to describe function values
+define function print-function-values
+ (server :: <server>, function-object :: <function-object>,
+ namespace :: false-or(<namespace-object>))
+ => (name :: <string>)
+ with-output-to-string (stream)
+ let <object>-class = find-environment-object(server, $<object>-id);
+ let (required-params, rest-param, key-params, all-keys?, next-param,
+ required-values, rest-value)
+ = function-parameters(server, function-object);
+ ignore(required-params, rest-param, key-params, all-keys?, next-param);
+ format(stream, "(");
+ local method do-value (parameter :: <parameter>) => ()
+ let type = parameter.parameter-type;
+ format(stream, "%s", parameter.parameter-name);
+ unless (type == <object>-class)
+ format(stream, " :: %s",
+ environment-object-display-name(server, type, namespace)
+ | $type-n/a)
+ end
+ end method do-value;
+ local method do-values (_values :: <parameters>) => ()
+ for (value in _values,
+ count from size(_values) - 1 by -1)
+ do-value(value);
+ if (count > 0)
+ format(stream, ", ")
+ end;
+ end for;
+ end method do-values;
+ do-values(required-values);
+ if (rest-value)
+ if (size(required-values) > 0)
+ format(stream, ", ");
+ end;
+ format(stream, "#rest ");
+ do-value(rest-value);
+ end;
+ format(stream, ")")
+ end
+end function print-function-values;
+
+
+/// Source location display
+
+define open generic print-environment-object-location
+ (server :: <server>, object :: <environment-object>)
+ => (location :: <string>);
+
+define method print-environment-object-location
+ (project :: <project-object>, object :: <environment-object>)
+ => (location :: <string>)
+ let source-location = environment-object-source-location(project, object);
+ if (source-location)
+ let source-record = source-location.source-location-source-record;
+ select (source-record by instance?)
+ <interactive-source-record> =>
+ $interactive-definition;
+ <file-source-record> =>
+ let location = source-record.source-record-location;
+ file-exists?(location) & location.locator-name;
+ otherwise =>
+ source-record.source-record-name;
+ end
+ end
+ | $n/a
+end method print-environment-object-location;
+
+define method print-environment-object-location
+ (project :: <project-object>,
+ project-object :: <project-object>)
+ => (location :: <string>)
+ ignore(project);
+ as(<string>,
+ project-object.project-filename
+ | project-object.project-debug-filename
+ | $n/a)
+end method print-environment-object-location;
+
Added: trunk/fundev/sources/environment/server/dummy/Open-Source-License.txt
==============================================================================
--- (empty file)
+++ trunk/fundev/sources/environment/server/dummy/Open-Source-License.txt Fri Mar 28 00:30:03 2008
@@ -0,0 +1,21 @@
+The contents of this library are subject to the Functional Objects Library
+Public License Version 1.0 (the "License"); you may not use this library
+except in compliance with the License. You may obtain a copy of the License
+at http://www.functionalobjects.com/licenses/library-public-license-1.0.txt
+
+Software distributed under the License is distributed on an "AS IS" basis,
+WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+for the specific language governing rights and limitations under the License.
+
+Original Code is Copyright (c) 1996-2004 Functional Objects, Inc.
+All rights reserved.
+
+Alternatively, the contents of this library may be used under the
+terms of the GNU Lesser General Public License (the "GLGPL"), in which
+case the provisions of the GLGPL are applicable instead of those above. If
+you wish to allow use of your version of this library only under the
+terms of the GLGPL and not to allow others to use your version of this
+library under the License, indicate your decision by deleting the provisions
+above and replace them with the notice and other provisions required
+by the GLGPL. If you do not delete the provisions above, a recipient
+may use your version of this library under either the License or the GLGPL.
Added: trunk/fundev/sources/environment/server/dummy/environment-server.dylan
==============================================================================
--- (empty file)
+++ trunk/fundev/sources/environment/server/dummy/environment-server.dylan Fri Mar 28 00:30:03 2008
@@ -0,0 +1,16 @@
+Module: environment-server
+Author: Hugh Greene
+Synopsis: Controlling the Environment from external sources.
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+// Whatever server we're supposed to run here...
+
+define function server-start () => ()
+end function;
+
+define function server-stop () => ()
+end function;
Added: trunk/fundev/sources/environment/server/dummy/environment-server.lid
==============================================================================
--- (empty file)
+++ trunk/fundev/sources/environment/server/dummy/environment-server.lid Fri Mar 28 00:30:03 2008
@@ -0,0 +1,11 @@
+Library: environment-server
+Target-Type: dll
+Files: library_module
+ environment-server
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+Other-files: Open-Source-License.txt
+
Added: trunk/fundev/sources/environment/server/dummy/library_module.dylan
==============================================================================
--- (empty file)
+++ trunk/fundev/sources/environment/server/dummy/library_module.dylan Fri Mar 28 00:30:03 2008
@@ -0,0 +1,29 @@
+Module: Dylan-User
+Author: Hugh Greene
+Synopsis: Controlling the Environment from external sources.
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+define library environment-server
+ use functional-dylan;
+
+ use channels;
+ use environment-manager;
+
+ export environment-server;
+end library environment-server;
+
+
+/// All external servers, plus commands and the call hooks.
+
+define module environment-server
+ use functional-dylan;
+ use channels;
+ use environment-manager;
+
+ export server-start,
+ server-stop;
+end module environment-server;
Modified: trunk/fundev/sources/environment/tools/describer.dylan
==============================================================================
--- trunk/fundev/sources/environment/tools/describer.dylan (original)
+++ trunk/fundev/sources/environment/tools/describer.dylan Fri Mar 28 00:30:03 2008
@@ -70,183 +70,6 @@
end method initialize;
-// Describer-specific methods
-
-define generic get-description
- (frame :: <environment-describer>, project :: <project-object>,
- object :: <environment-object>, module :: <module-object>)
- => (description :: <string>);
-
-define open generic environment-object-contents
- (project :: <project-object>, environment-object :: <environment-object>)
- => (contents :: <string>);
-
-define method get-description
- (frame :: <environment-describer>, project :: <project-object>,
- object :: <environment-object>, module :: <module-object>)
- => (description :: <string>)
- environment-object-unique-name(project, object, module, qualify-names?: #t)
-end method get-description;
-
-define method get-description
- (frame :: <environment-describer>, project :: <project-object>,
- object :: <definition-object>, module :: <module-object>)
- => (description :: <string>)
- let home-name
- = environment-object-home-name(project, object);
- if (instance?(home-name, <binding-name-object>))
- let name = environment-object-primitive-name(project, home-name);
- let home-module = name-namespace(project, home-name);
- let home-library = environment-object-library(project, home-module);
- let module-name = environment-object-primitive-name(project, home-module);
- let library-name = environment-object-primitive-name(project, home-library);
- let location = print-environment-object-location(project, object, module);
- let type-name = environment-object-type-name(object);
- concatenate
- (// The "Name:" is in the title bar.
- "In module ", module-name,
- ", library ", library-name,
- ", from file ", location, ":\n",
- type-name, " ", name)
- else
- environment-object-unique-name
- (project, object, module, qualify-names?: #t)
- end
-end method get-description;
-
-define method get-description
- (frame :: <environment-describer>, project :: <project-object>,
- object :: <user-object>, module :: <module-object>)
- => (description :: <string>)
- if (instance?(object, <definition-object>))
- next-method()
- else
- let class = application-object-class(project, object);
- concatenate
- (format-to-string
- ("Object %s:\n",
- environment-object-unique-name
- (project, object, module, qualify-names?: #t)),
- if (class)
- get-description(frame, project, class, module)
- else
- #[]
- end)
- end
-end method get-description;
-
-define method get-description
- (frame :: <environment-describer>, project :: <project-object>,
- object :: <collection-object>, module :: <module-object>)
- => (description :: <string>)
- let size = collection-size(project, object);
- concatenate
- (format-to-string
- ("Collection %s:\n",
- environment-object-unique-name
- (project, object, module, qualify-names?: #t)),
- format-to-string("Size: %s\n", size | ""))
-end method get-description;
-
-define macro get-description-method-definer
- { define get-description-method ( ?class:name )
- ?:body
- end }
- => { define method get-description
- (?=frame :: <environment-describer>, ?=project :: <project-object>,
- ?=object :: ?class, ?=module :: <module-object>,
- #next next-method)
- => (description :: <string>)
- concatenate(next-method(), begin ?body end | "")
- end method get-description }
-end macro get-description-method-definer;
-
-define function names->name-list
- (names :: <sequence> /* of: <string> */)
- => (name-list :: <string>)
- concatenate
- ("(",
- select (names.size)
- 0 => "";
- 1 => names[0];
- otherwise =>
- reduce1
- (method (names-so-far, new-name)
- concatenate(names-so-far, ", ", new-name)
- end,
- names);
- end,
- ")")
-end function names->name-list;
-
-define get-description-method (<class-object>)
- // ---*** Can we show init-keywords, including those accepted by make
- // and initialize methods?
- let superclass-names :: <sequence>
- = map(method (class-object)
- environment-object-display-name(project, class-object, module)
- end,
- class-direct-superclasses(project, object));
- names->name-list(superclass-names)
-end get-description-method;
-
-define get-description-method (<domain-object>)
- let specializers = domain-specializers(project, object);
- names->name-list(specializers)
-end get-description-method;
-
-// Covers "define {generic,method,function}".
-define get-description-method (<dylan-function-object>)
- // ---*** Can we, for <generic-function-object>s, show all keywords
- // accepted by all methods (of those defined at compile-time)?
- // ---*** For make and initialize, can we show keyword parameters from
- // slots descriptions for the relevant class?
- concatenate
- ("\n ",
- print-function-parameters(project, object, module),
- "\n => ",
- print-function-values(project, object, module))
-end get-description-method;
-
-define get-description-method (<library-object>)
- concatenate
- ("\nContents:\t",
- environment-object-contents(project, object));
-end get-description-method;
-
-define get-description-method (<macro-object>)
- // ---*** Would like the lhs of the first main rule.
-end get-description-method;
-
-define get-description-method (<module-object>)
- concatenate
- ("\nContents:\t",
- environment-object-contents(project, object));
-end get-description-method;
-
-define get-description-method (<module-variable-object>)
- let type = variable-type(project, object);
- concatenate
- (" :: ",
- if (type)
- environment-object-display-name(project, type, module)
- else
- $unknown
- end)
-end get-description-method;
-
-define get-description-method (<constant-object>)
- let type = variable-type(project, object);
- concatenate
- (" :: ",
- if (type)
- environment-object-display-name(project, type, module)
- else
- $unknown
- end)
-end get-description-method;
-
-
// "Service" function, mainly for use by environment-manager library.
define sideways method show-definition-summary
(name :: <string>,
@@ -280,7 +103,7 @@
("No project and module context in which to find %s.", name);
object =>
with-busy-cursor (describer)
- get-description(describer, project, object, module)
+ environment-object-description(project, object, module)
end;
otherwise =>
let module-name = environment-object-home-name(project, module);
Modified: trunk/fundev/sources/environment/tools/module.dylan
==============================================================================
--- trunk/fundev/sources/environment/tools/module.dylan (original)
+++ trunk/fundev/sources/environment/tools/module.dylan Fri Mar 28 00:30:03 2008
@@ -38,9 +38,7 @@
use environment-server;
// Some useful constants
- export $n/a,
- $unknown,
- project-not-built-message;
+ export project-not-built-message;
// Environment startup (shutdown is managed by the Env-Framework)
export start-environment;
@@ -60,14 +58,10 @@
// Printing functions
export compilation-warning-count-message,
- environment-object-contents,
frame-print-environment-object,
frame-object-unique-name,
frame-default-object-name,
- frame-qualify-names?, frame-qualify-names?-setter,
- print-function-parameters,
- print-function-values,
- print-environment-object-location;
+ frame-qualify-names?, frame-qualify-names?-setter;
// Percentages
export <percentage>,
Modified: trunk/fundev/sources/environment/tools/object-names.dylan
==============================================================================
--- trunk/fundev/sources/environment/tools/object-names.dylan (original)
+++ trunk/fundev/sources/environment/tools/object-names.dylan Fri Mar 28 00:30:03 2008
@@ -11,14 +11,6 @@
define constant $maximum-object-name-length = 2000;
-define constant $n/a = "n/a";
-define constant $type-n/a = "<?>";
-define constant $no-information-available = "No information available";
-define constant $unknown-name = "{unknown-name}";
-define constant $unknown = "unknown";
-define constant $project-not-built = "[project not built]";
-define constant $interactive-definition = "interactive definition";
-
/// General printing functions
@@ -117,167 +109,6 @@
end method frame-print-environment-object;
-/// Function names
-
-define constant $show-keyword-function-names = #f;
-
-// Create a user-visible string to describe function parameters
-define function print-function-parameters
- (server :: <server>, function-object :: <function-object>,
- namespace :: false-or(<namespace-object>))
- => (name :: <string>)
- with-output-to-string (stream)
- let <object>-class = find-environment-object(server, $<object>-id);
- let (required, rest, key, all-keys?, next) // ... values, rest-value)
- = function-parameters(server, function-object);
- format(stream, "(");
- local method do-parameter (parameter :: <parameter>) => ()
- let keyword
- = instance?(parameter, <optional-parameter>)
- & parameter.parameter-keyword;
- let type = parameter.parameter-type;
- if ($show-keyword-function-names)
- if (keyword)
- format(stream, "%s: ", keyword)
- end;
- format(stream, "%s", parameter.parameter-name);
- else
- format(stream, "%s", keyword | parameter.parameter-name)
- end;
- unless (type == <object>-class)
- format(stream, " :: %s",
- environment-object-display-name(server, type, namespace)
- | $type-n/a)
- end
- end method do-parameter;
- local method do-parameters (parameters :: <parameters>) => ()
- for (parameter :: <parameter> in parameters,
- separator = "" then ", ")
- format(stream, separator);
- do-parameter(parameter)
- end for;
- end method do-parameters;
- do-parameters(required);
- let printed-something = size(required) > 0;
- local method print-separator () => ()
- if (printed-something)
- format(stream, ", ");
- else
- printed-something := #t;
- end;
- end method print-separator;
- if (next)
- print-separator();
- format(stream, "#next ");
- do-parameter(next);
- end;
- if (rest)
- print-separator();
- format(stream, "#rest ");
- do-parameter(rest);
- end;
- case
- key & size(key) > 0 =>
- print-separator();
- format(stream, "#key ");
- do-parameters(key);
- if (all-keys?)
- format(stream, ", #all-keys")
- end;
- all-keys? =>
- print-separator();
- format(stream, "#key, #all-keys");
- otherwise =>
- #f;
- end;
- format(stream, ")");
- end
-end function print-function-parameters;
-
-// Create a user-visible string to describe function values
-define function print-function-values
- (server :: <server>, function-object :: <function-object>,
- namespace :: false-or(<namespace-object>))
- => (name :: <string>)
- with-output-to-string (stream)
- let <object>-class = find-environment-object(server, $<object>-id);
- let (required-params, rest-param, key-params, all-keys?, next-param,
- required-values, rest-value)
- = function-parameters(server, function-object);
- ignore(required-params, rest-param, key-params, all-keys?, next-param);
- format(stream, "(");
- local method do-value (parameter :: <parameter>) => ()
- let type = parameter.parameter-type;
- format(stream, "%s", parameter.parameter-name);
- unless (type == <object>-class)
- format(stream, " :: %s",
- environment-object-display-name(server, type, namespace)
- | $type-n/a)
- end
- end method do-value;
- local method do-values (_values :: <parameters>) => ()
- for (value in _values,
- count from size(_values) - 1 by -1)
- do-value(value);
- if (count > 0)
- format(stream, ", ")
- end;
- end for;
- end method do-values;
- do-values(required-values);
- if (rest-value)
- if (size(required-values) > 0)
- format(stream, ", ");
- end;
- format(stream, "#rest ");
- do-value(rest-value);
- end;
- format(stream, ")")
- end
-end function print-function-values;
-
-
-/// Source location display
-
-define open generic print-environment-object-location
- (server :: <server>, object :: <environment-object>,
- namespace :: false-or(<namespace-object>))
- => (location :: <string>);
-
-define method print-environment-object-location
- (project :: <project-object>, object :: <environment-object>,
- namespace :: false-or(<namespace-object>))
- => (location :: <string>)
- ignore(project, object, namespace);
- let source-location = environment-object-source-location(project, object);
- if (source-location)
- let source-record = source-location.source-location-source-record;
- select (source-record by instance?)
- <interactive-source-record> =>
- $interactive-definition;
- <file-source-record> =>
- let location = source-record.source-record-location;
- file-exists?(location) & location.locator-name;
- otherwise =>
- source-record.source-record-name;
- end
- end
- | $n/a
-end method print-environment-object-location;
-
-define method print-environment-object-location
- (project :: <project-object>,
- project-object :: <project-object>,
- namespace :: false-or(<namespace-object>))
- => (location :: <string>)
- ignore(project, namespace);
- as(<string>,
- project-object.project-filename
- | project-object.project-debug-filename
- | $n/a)
-end method print-environment-object-location;
-
-
/// Find named objects
define method find-named-object
Modified: trunk/fundev/sources/lib/cl/cl-strings.dylan
==============================================================================
--- trunk/fundev/sources/lib/cl/cl-strings.dylan (original)
+++ trunk/fundev/sources/lib/cl/cl-strings.dylan Fri Mar 28 00:30:03 2008
@@ -650,12 +650,12 @@
// Pluralize the given string
define method string-pluralize
- (string :: <string>) => (plural :: <string>)
+ (string :: <string>, #key count) => (plural :: <string>)
block (return)
let length = size(string);
let pos
= (string-search-set(string, #(' ', '\t'), from-end?: #t) | -1) + 1;
- if (zero?(length))
+ if (zero?(length) | (count & count = 1))
return(string)
end;
let flush = #f;
Added: trunk/fundev/sources/registry/generic/environment-server
==============================================================================
--- (empty file)
+++ trunk/fundev/sources/registry/generic/environment-server Fri Mar 28 00:30:03 2008
@@ -0,0 +1 @@
+abstract://dylan/environment/server/dummy/environment-server.lid
More information about the chatter
mailing list