>From 5b0dafb33b288aaf3fa552732b77341ed1be7c4b Mon Sep 17 00:00:00 2001
From: Gwenael Casaccio
Date: Mon, 24 Jun 2013 18:11:00 +0200
Subject: [PATCH] Add support for DebugInformation (final)
---
ChangeLog | 15 ++++++++
kernel/CompildMeth.st | 24 +++++++++++++
kernel/CompiledBlk.st | 12 +++++++
kernel/DebugInformation.st | 70 ++++++++++++++++++++++++++++++++++++++
kernel/MethodInfo.st | 14 +++++++-
libgst/comp.c | 85 +++++++++++++++++++++++++++++++++++++++++++---
libgst/comp.h | 2 ++
libgst/dict.c | 23 ++++++-------
libgst/dict.h | 7 ++++
libgst/files.c | 1 +
packages.xml | 1 +
tests/stcompiler.ok | 7 ++++
tests/stcompiler.st | 20 +++++++++++
13 files changed, 264 insertions(+), 17 deletions(-)
create mode 100644 kernel/DebugInformation.st
diff --git a/ChangeLog b/ChangeLog
index d5395cc..bb14969 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2013-06-24 Gwenael Casaccio
+
+ * kernel/DebugInformation.st: Add DebugInformation.
+ * kernel/CompildMeth.st: Add DebugInformation support.
+ * kernel/CompiledBlk.st: Add DebugInformation support.
+ * kernel/MethodInfo.st: Add DebugInformation support.
+ * libgst/comp.c: Add arguments and temporaries name in DebugInformation.
+ * libgst/comp.h: Add a debugInfo state in the compiler.
+ * libgst/dict.c: Add _gst_identity_dictionary_new.
+ * libgst/dict.h: Add _gst_identity_dictionary_new.
+ * libgst/files.c: Bootstrap information for DebugInformation.
+ * packages.xml: Bootstrap information for DebugInformation.
+ * tests/stcompiler.ok: Tests for DebugInformations.
+ * tests/stcompiler.st: Tests for DebugInformations.
+
2013-06-14 Jochen Schmitt
* smalltalk-mode-init.el.in: Use inhibit-local-variables-regexps
diff --git a/kernel/CompildMeth.st b/kernel/CompildMeth.st
index 45fc3b9..5a9b056 100644
--- a/kernel/CompildMeth.st
+++ b/kernel/CompildMeth.st
@@ -756,5 +756,29 @@ instances.'>
self become: newMethod.
^nil
]
+
+ arguments [
+
+
+ ^ self argumentsFor: self
+ ]
+
+ temporaries [
+
+
+ ^ self temporariesFor: self
+ ]
+
+ argumentsFor: anObject [
+
+
+ ^ self descriptor argumentsFor: anObject
+ ]
+
+ temporariesFor: anObject [
+
+
+ ^ self descriptor temporariesFor: anObject
+ ]
]
diff --git a/kernel/CompiledBlk.st b/kernel/CompiledBlk.st
index 96a2b8d..d5ca707 100644
--- a/kernel/CompiledBlk.st
+++ b/kernel/CompiledBlk.st
@@ -280,5 +280,17 @@ CompiledCode subclass: CompiledBlock [
receiver: self method]].
self error: 'object cannot be dumped'
]
+
+ arguments [
+
+
+ ^ self method argumentsFor: self
+ ]
+
+ temporaries [
+
+
+ ^ self method temporariesFor: self
+ ]
]
diff --git a/kernel/DebugInformation.st b/kernel/DebugInformation.st
new file mode 100644
index 0000000..23a1635
--- /dev/null
+++ b/kernel/DebugInformation.st
@@ -0,0 +1,70 @@
+"======================================================================
+|
+| Object Method Definitions
+|
+|
+ ======================================================================"
+
+"======================================================================
+|
+| Copyright 2013 Free Software Foundation, Inc.
+| Written by Gwenael Casaccio.
+|
+| This file is part of the GNU Smalltalk class library.
+|
+| The GNU Smalltalk class library is free software; you can redistribute it
+| and/or modify it under the terms of the GNU Lesser General Public License
+| as published by the Free Software Foundation; either version 2.1, or (at
+| your option) any later version.
+|
+| The GNU Smalltalk class library is distributed in the hope that it will be
+| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
+| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
+| General Public License for more details.
+|
+| You should have received a copy of the GNU Lesser General Public License
+| along with the GNU Smalltalk class library; see the file COPYING.LIB.
+| If not, write to the Free Software Foundation, 59 Temple Place - Suite
+| 330, Boston, MA 02110-1301, USA.
+|
+ ======================================================================"
+
+
+Object subclass: DebugInformation [
+
+ DebugInformation class >> variables: anArray [
+
+
+ ^ self new
+ variables: anArray;
+ yourself
+ ]
+
+ | variables |
+
+ variables: anArray [
+
+
+ variables := anArray.
+ ]
+
+ variables [
+
+
+ ^ variables
+ ]
+
+ arguments: anInteger [
+
+
+ ^ variables copyFrom: 1 to: anInteger
+ ]
+
+ temporaries: anInteger [
+
+
+ ^ variables copyFrom: anInteger + 1 to: variables size
+ ]
+]
+
+
diff --git a/kernel/MethodInfo.st b/kernel/MethodInfo.st
index c58ba79..47ef495 100644
--- a/kernel/MethodInfo.st
+++ b/kernel/MethodInfo.st
@@ -33,7 +33,7 @@
Object subclass: MethodInfo [
- | sourceCode category class selector |
+ | sourceCode category class selector debugInfo |
@@ -140,5 +140,17 @@ code of the method.'>
sourceCode := source
]
+
+ argumentsFor: anObject [
+
+
+ ^ (debugInfo at: anObject) arguments: anObject numArgs
+ ]
+
+ temporariesFor: anObject [
+
+
+ ^ (debugInfo at: anObject) temporaries: anObject numArgs
+ ]
]
diff --git a/libgst/comp.c b/libgst/comp.c
index 10330e1..f03b380 100644
--- a/libgst/comp.c
+++ b/libgst/comp.c
@@ -534,6 +534,9 @@ _gst_execute_statements (OOP receiverOOP,
memset (&s, 0, sizeof (s));
_gst_compiler_state->undeclared_temporaries = undeclared;
+ _gst_compiler_state->debugInfoDict = _gst_identity_dictionary_new (_gst_identity_dictionary_class, 6);
+ INC_ADD_OOP (_gst_compiler_state->debugInfoDict);
+
if (setjmp (_gst_compiler_state->bad_method) == 0)
{
resultOOP = _gst_make_constant_oop (statements->v_list.value);
@@ -692,6 +695,10 @@ _gst_compile_method (tree_node method,
OOP methodOOP;
bc_vector bytecodes;
int stack_depth;
+ int i, argCount, tempCount;
+ OOP variablesOOP, debugInfo;
+ gst_object object;
+ tree_node args;
inc_ptr incPtr;
gst_compiled_method compiledMethod;
@@ -719,6 +726,9 @@ _gst_compile_method (tree_node method,
_gst_push_new_scope ();
selector = compute_selector (method->v_method.selectorExpr);
+ _gst_compiler_state->debugInfoDict = _gst_identity_dictionary_new (_gst_identity_dictionary_class, 6);
+ INC_ADD_OOP (_gst_compiler_state->debugInfoDict);
+
/* When we are reading from stdin, it's better to write line numbers where
1 is the first line *in the current doit*, because for now the prompt
does not include the line number. This might change in the future.
@@ -738,14 +748,18 @@ _gst_compile_method (tree_node method,
methodOOP = _gst_nil_oop;
if (setjmp (_gst_compiler_state->bad_method) == 0)
{
- if (_gst_declare_arguments (method->v_method.selectorExpr) == -1)
+ argCount = _gst_declare_arguments (method->v_method.selectorExpr);
+
+ if (argCount == -1)
{
_gst_errorf_at (method->location.first_line,
"duplicate argument name");
EXIT_COMPILATION ();
}
- if (_gst_declare_temporaries (method->v_method.temporaries) == -1)
+ tempCount = _gst_declare_temporaries (method->v_method.temporaries);
+
+ if (tempCount == -1)
{
_gst_errorf_at (method->location.first_line,
"duplicate temporary variable name");
@@ -826,11 +840,48 @@ _gst_compile_method (tree_node method,
selector, method->v_method.currentCategory,
method->location.file_offset,
method->v_method.endPos);
+
+ if (methodOOP != _gst_nil_oop) {
+ INC_ADD_OOP (methodOOP);
+
+ object = new_instance_with (_gst_array_class, argCount + tempCount, &variablesOOP);
+ INC_ADD_OOP (variablesOOP);
+
+ args = method->v_method.selectorExpr;
+ i = 0;
+
+ if (args->nodeType == TREE_BINARY_EXPR)
+ {
+ object->data[i] = _gst_intern_string (args->v_expr.expression->v_list.name);
+ i += 1;
+ }
+ else
+ {
+ for (args = args->v_expr.expression; args != NULL; args = args->v_list.next)
+ {
+ object->data[i] = _gst_intern_string (args->v_list.value->v_list.name);
+ i += 1;
+ }
+ }
+
+ for (args = method->v_method.temporaries; args != NULL; args = args->v_list.next)
+ {
+ object->data[i] = _gst_intern_string (args->v_list.name);
+ i += 1;
+ }
+
+ new_instance (_gst_debug_information_class, &debugInfo);
+ INC_ADD_OOP (debugInfo);
+
+ inst_var_at_put (debugInfo, 1, variablesOOP);
+ _gst_identity_dictionary_at_put (_gst_compiler_state->debugInfoDict, methodOOP, debugInfo);
+ inst_var_at_put (inst_var_at (methodOOP, 3), 5, _gst_compiler_state->debugInfoDict);
+ }
+
}
if (methodOOP != _gst_nil_oop)
{
- INC_ADD_OOP (methodOOP);
compiledMethod = (gst_compiled_method) OOP_TO_OBJ (methodOOP);
compiledMethod->header.isOldSyntax = method->v_method.isOldSyntax;
@@ -1064,9 +1115,13 @@ compile_block (tree_node blockExpr)
bc_vector current_bytecodes, blockByteCodes;
int argCount, tempCount;
int stack_depth;
- OOP blockClosureOOP, blockOOP;
+ int i;
+ OOP blockClosureOOP, blockOOP, variablesOOP;
+ OOP debugInfo;
gst_compiled_block block;
+ gst_object object;
inc_ptr incPtr;
+ tree_node args;
current_bytecodes = _gst_save_bytecode_array ();
@@ -1102,6 +1157,27 @@ compile_block (tree_node blockExpr)
blockOOP = make_block (_gst_get_arg_count (), _gst_get_temp_count (),
blockByteCodes, stack_depth);
INC_ADD_OOP (blockOOP);
+
+ object = new_instance_with (_gst_array_class, argCount + tempCount, &variablesOOP);
+ INC_ADD_OOP (variablesOOP);
+
+ for (i = 0, args = blockExpr->v_block.arguments; args != NULL; args = args->v_list.next) {
+ object->data[i] = _gst_intern_string (args->v_list.name);
+ i += 1;
+ }
+
+ for (args = blockExpr->v_block.temporaries; args != NULL; args = args->v_list.next) {
+ object->data[i] = _gst_intern_string (args->v_list.name);
+ i += 1;
+ }
+
+ new_instance (_gst_debug_information_class, &debugInfo);
+ INC_ADD_OOP (debugInfo);
+
+ inst_var_at_put (debugInfo, 1, variablesOOP);
+
+ _gst_identity_dictionary_at_put (_gst_compiler_state->debugInfoDict, blockOOP, debugInfo);
+
_gst_pop_old_scope ();
/* emit standard byte sequence to invoke a block:
@@ -2739,6 +2815,7 @@ method_info_new (OOP class,
methodInfo->category = categoryOOP;
methodInfo->class = class;
methodInfo->selector = selector;
+ methodInfo->debugInfo = _gst_nil_oop;
while (attrs)
{
diff --git a/libgst/comp.h b/libgst/comp.h
index 91a1f9c..f10f2c0 100644
--- a/libgst/comp.h
+++ b/libgst/comp.h
@@ -148,6 +148,7 @@ typedef struct gst_method_info
OOP category;
OOP class;
OOP selector;
+ OOP debugInfo;
OOP attributes[1];
}
*gst_method_info;
@@ -234,6 +235,7 @@ typedef struct compiler_state
OOP *literal_vec;
OOP *literal_vec_curr;
OOP *literal_vec_max;
+ OOP debugInfoDict;
jmp_buf bad_method;
} compiler_state;
diff --git a/libgst/dict.c b/libgst/dict.c
index f4324b7..0b4ddb9 100644
--- a/libgst/dict.c
+++ b/libgst/dict.c
@@ -177,6 +177,7 @@ OOP _gst_weak_key_identity_dictionary_class = NULL;
OOP _gst_weak_value_identity_dictionary_class = NULL;
OOP _gst_write_stream_class = NULL;
OOP _gst_processor_oop = NULL;
+OOP _gst_debug_information_class = NULL;
/* Called when a dictionary becomes full, this routine replaces the
dictionary instance that DICTIONARYOOP is pointing to with a new,
@@ -216,11 +217,6 @@ static int _gst_identity_dictionary_at_inc (OOP identityDictionaryOOP,
OOP keyOOP,
int inc);
-/* Create a new instance of CLASSOOP (an IdentityDictionary subclass)
- and answer it. */
-static OOP identity_dictionary_new (OOP classOOP,
- int size);
-
/* Create a new instance of Namespace with the given SIZE, NAME and
superspace (SUPERSPACEOOP). */
static OOP namespace_new (int size,
@@ -742,12 +738,16 @@ static const class_definition class_info[] = {
"Memory", NULL, NULL, NULL },
{&_gst_method_info_class, &_gst_object_class,
- GST_ISP_POINTER, true, 4,
- "MethodInfo", "sourceCode category class selector", NULL, NULL },
+ GST_ISP_POINTER, true, 5,
+ "MethodInfo", "sourceCode category class selector debugInfo", NULL, NULL },
{&_gst_file_segment_class, &_gst_object_class,
GST_ISP_FIXED, true, 3,
- "FileSegment", "file startPos size", NULL, NULL }
+ "FileSegment", "file startPos size", NULL, NULL },
+
+ {&_gst_debug_information_class, &_gst_object_class,
+ GST_ISP_FIXED, true, 1,
+ "DebugInformation", "variables", NULL, NULL }
/* Classes not defined here (like Point/Rectangle/RunArray) are
defined after the kernel has been fully initialized. */
@@ -1405,7 +1405,7 @@ _gst_valid_class_method_dictionary (OOP class_oop)
{
OOP methodDictionaryOOP;
methodDictionaryOOP =
- identity_dictionary_new (_gst_method_dictionary_class, 32);
+ _gst_identity_dictionary_new (_gst_method_dictionary_class, 32);
class = (gst_class) OOP_TO_OBJ (class_oop);
class->methodDictionary = methodDictionaryOOP;
}
@@ -1625,7 +1625,6 @@ grow_identity_dictionary (OOP oldIdentityDictionaryOOP)
identityDictionary =
instantiate_with (OOP_CLASS (oldIdentityDictionaryOOP), numFields * 2,
&identityDictionaryOOP);
-
oldIdentityDictionary = OOP_TO_OBJ (oldIdentityDictionaryOOP);
oldIdentDict = (gst_identity_dictionary) oldIdentityDictionary;
identDict = (gst_identity_dictionary) identityDictionary;
@@ -1721,7 +1720,7 @@ identity_dictionary_find_key_or_nil (OOP identityDictionaryOOP,
}
OOP
-identity_dictionary_new (OOP classOOP, int size)
+_gst_identity_dictionary_new (OOP classOOP, int size)
{
gst_identity_dictionary identityDictionary;
OOP identityDictionaryOOP;
@@ -2206,7 +2205,7 @@ _gst_record_profile (OOP oldMethod, OOP newMethod, int ipOffset)
profile = _gst_identity_dictionary_at (_gst_raw_profile, oldMethod);
if UNCOMMON (IS_NIL (profile))
{
- profile = identity_dictionary_new (_gst_identity_dictionary_class, 6);
+ profile = _gst_identity_dictionary_new (_gst_identity_dictionary_class, 6);
_gst_identity_dictionary_at_put (_gst_raw_profile, oldMethod,
profile);
}
diff --git a/libgst/dict.h b/libgst/dict.h
index 9202b23..5aaa7eb 100644
--- a/libgst/dict.h
+++ b/libgst/dict.h
@@ -439,6 +439,7 @@ extern OOP _gst_weak_key_identity_dictionary_class ATTRIBUTE_HIDDEN;
extern OOP _gst_weak_value_identity_dictionary_class ATTRIBUTE_HIDDEN;
extern OOP _gst_write_stream_class ATTRIBUTE_HIDDEN;
extern OOP _gst_processor_oop ATTRIBUTE_HIDDEN;
+extern OOP _gst_debug_information_class ATTRIBUTE_HIDDEN;
/* The size of the indexed instance variables corresponding to the
various instanceSpec values declared in gstpriv.h. */
@@ -487,6 +488,12 @@ extern OOP _gst_dictionary_add (OOP dictionaryOOP,
OOP associationOOP)
ATTRIBUTE_HIDDEN;
+/* Create a new instance of CLASSOOP (an IdentityDictionary subclass)
+ and answer it. */
+extern OOP _gst_identity_dictionary_new (OOP classOOP,
+ int size)
+ ATTRIBUTE_HIDDEN;
+
/* Look for the value associated to KEYOOP in IDENTITYDICTIONARYOOP
and answer it or, if not found, _gst_nil_oop. */
extern OOP _gst_identity_dictionary_at (OOP identityDictionaryOOP,
diff --git a/libgst/files.c b/libgst/files.c
index a7156f9..06ecfd2 100644
--- a/libgst/files.c
+++ b/libgst/files.c
@@ -236,6 +236,7 @@ static const char standard_files[] = {
"Continuation.st\0"
"Memory.st\0"
"MethodInfo.st\0"
+ "DebugInformation.st\0"
"FileSegment.st\0"
"FileDescr.st\0"
"SymLink.st\0"
diff --git a/packages.xml b/packages.xml
index fc6a049..c3b6514 100644
--- a/packages.xml
+++ b/packages.xml
@@ -189,6 +189,7 @@
LinkedList.st
Rectangle.st
AnsiDates.st
+ DebugInformation.st
CompildCode.st
LookupKey.st
BindingDict.st
diff --git a/tests/stcompiler.ok b/tests/stcompiler.ok
index a0cebf4..4587736 100644
--- a/tests/stcompiler.ok
+++ b/tests/stcompiler.ok
@@ -60,3 +60,10 @@ Execution begins...
true
true
returned value is true
+
+Execution begins...
+true
+true
+true
+true
+returned value is nil
diff --git a/tests/stcompiler.st b/tests/stcompiler.st
index 5605a6e..a645741 100644
--- a/tests/stcompiler.st
+++ b/tests/stcompiler.st
@@ -140,3 +140,23 @@ Eval [
(bla sharedPools = #('STInST') asOrderedCollection) printNl.
(bla classVarNames = #('ClassInst') asOrderedCollection) printNl.
]
+
+"Test debug informations are generated"
+Object subclass: Foo [
+ a_1: i_1 a_2: i_2 [
+ | i j k |
+
+ ^ [ :a :b :c | | d e f | ]
+ ]
+]
+
+Eval [
+ | mth |
+ mth := Foo>>#'a_1:a_2:'.
+ (mth arguments = #(#'i_1' #'i_2')) printNl.
+ (mth temporaries = #(#'i' #'j' #'k')) printNl.
+ ((mth blockAt: 1) arguments = #(#'a' #'b' #'c')) printNl.
+ ((mth blockAt: 1) temporaries = #(#'d' #'e' #'f')) printNl.
+ nil
+]
+
--
1.8.1.2