From b4e1916be1c25adfb51f0b43df3cf82925c0d6b0 Mon Sep 17 00:00:00 2001
From: jgarcia <jgarcia>
Date: Tue, 22 Apr 2008 12:29:44 +0000
Subject: [PATCH] Let interpreted forms remember the file they come from

---
 src/CHANGELOG         |  3 +++
 src/c/compiler.d      |  4 ++++
 src/c/disassembler.d  | 10 ++++++++++
 src/c/load.d          |  5 +++++
 src/c/symbols_list.h  |  3 +++
 src/c/symbols_list2.h |  3 +++
 src/h/external.h      |  1 +
 src/h/object.h        |  2 ++
 src/lsp/config.lsp.in |  2 +-
 9 files changed, 32 insertions(+), 1 deletion(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index 3d85d03b6..054556b24 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -70,6 +70,9 @@ ECL 0.9k:
    or shadow import the symbols associated to generic versions in the packages
    where methods on these functions are defined.
 
+ - Interpreted forms now remember the file in which they were defined
+   and what form number they represent.
+
 * CLOS:
 
  - When caching generic function calls, ECL now uses a thread-local hash table
diff --git a/src/c/compiler.d b/src/c/compiler.d
index 1da6a5f8d..2bf16b589 100644
--- a/src/c/compiler.d
+++ b/src/c/compiler.d
@@ -144,6 +144,8 @@ asm_end(cl_index beginning) {
 	cl_object bytecodes;
 	cl_index code_size, data_size, i;
 	cl_opcode *code;
+	cl_object file = SYM_VAL(@'*load-pathname*');
+	cl_object position = SYM_VAL(@'ext::*load-position*');
 
 	/* Save bytecodes from this session in a new vector */
 	code_size = current_pc() - beginning;
@@ -154,6 +156,8 @@ asm_end(cl_index beginning) {
 	bytecodes->bytecodes.code = cl_alloc_atomic(code_size * sizeof(cl_opcode));
 	bytecodes->bytecodes.data = (cl_object*)cl_alloc(data_size * sizeof(cl_object));
 	bytecodes->bytecodes.lex = Cnil;
+	bytecodes->bytecodes.file = (file == OBJNULL)? Cnil : file;
+	bytecodes->bytecodes.file_position = (position == OBJNULL)? Cnil : position;
 	for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) {
 		code[i] =
 			(cl_fixnum)cl_env.stack[beginning+i];
diff --git a/src/c/disassembler.d b/src/c/disassembler.d
index 3bcc74b6e..5fbb9a0eb 100644
--- a/src/c/disassembler.d
+++ b/src/c/disassembler.d
@@ -671,3 +671,13 @@ si_bc_split(cl_object b)
 	data->vector.self.t = b->bytecodes.data;
 	@(return b->bytecodes.lex vector data)
 }
+
+cl_object
+si_bc_file(cl_object b)
+{
+	if (type_of(b) != t_bytecodes) {
+		@(return Cnil Cnil);
+	} else {
+		@(return b->bytecodes.file b->bytecodes.file_position);
+	}
+}
diff --git a/src/c/load.d b/src/c/load.d
index 51b3f409f..621dc48d2 100644
--- a/src/c/load.d
+++ b/src/c/load.d
@@ -390,6 +390,8 @@ si_load_source(cl_object source, cl_object verbose, cl_object print)
 			@(return Cnil)
 	}
 	CL_UNWIND_PROTECT_BEGIN {
+		cl_object form_index = MAKE_FIXNUM(0);
+		bds_bind(@'ext::*load-position*', MAKE_FIXNUM(0));
 		for (;;) {
 			x = cl_read(3, strm, Cnil, OBJNULL);
 			if (x == OBJNULL)
@@ -399,7 +401,10 @@ si_load_source(cl_object source, cl_object verbose, cl_object print)
 				@write(1, x);
 				@terpri(0);
 			}
+			form_index = ecl_plus(MAKE_FIXNUM(1),form_index);
+			ECL_SETQ(@'ext::*load-position*', form_index);
 		}
+		bds_unwind1();
 	} CL_UNWIND_PROTECT_EXIT {
 		/* We do not want to come back here if close_stream fails,
 		   therefore, first we frs_pop() current jump point, then
diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h
index d2e669d24..cfb2ddc38 100644
--- a/src/c/symbols_list.h
+++ b/src/c/symbols_list.h
@@ -1690,6 +1690,9 @@ cl_symbols[] = {
 
 {"LOG1P", SI_ORDINARY, si_log1p, 1, OBJNULL},
 
+{EXT_ "*LOAD-POSITION*", SI_SPECIAL, NULL, -1, Cnil},
+{EXT_ "BC-FILE", SI_ORDINARY, si_bc_file, 1, Cnil},
+
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};
 
diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h
index b3cd59ee7..26e816d09 100644
--- a/src/c/symbols_list2.h
+++ b/src/c/symbols_list2.h
@@ -1690,6 +1690,9 @@ cl_symbols[] = {
 
 {"LOG1P","si_log1p"},
 
+{EXT_ "*LOAD-POSITION*",NULL},
+{EXT_ "BC-FILE","si_bc_file"},
+
 /* Tag for end of list */
 {NULL,NULL}};
 
diff --git a/src/h/external.h b/src/h/external.h
index f2e1c265a..8fc81029b 100644
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -465,6 +465,7 @@ extern ECL_API void *ecl_interpret(cl_object bytecodes, void *pc);
 
 extern ECL_API cl_object si_bc_disassemble(cl_object v);
 extern ECL_API cl_object si_bc_split(cl_object v);
+extern ECL_API cl_object si_bc_file(cl_object v);
 
 /* error.c */
 
diff --git a/src/h/object.h b/src/h/object.h
index a23ce4c64..dd6be542e 100644
--- a/src/h/object.h
+++ b/src/h/object.h
@@ -464,6 +464,8 @@ struct ecl_bytecodes {
 	cl_index data_size;	/*  number of constants  */
 	char *code;		/*  the intermediate language  */
 	cl_object *data;	/*  non-inmediate constants used in the code  */
+	cl_object file;		/*  file where it was defined...  */
+	cl_index file_position;	/*  and where it was created  */
 };
 
 struct ecl_cfun {		/*  compiled function header  */
diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in
index e8eb1893d..d711a5270 100644
--- a/src/lsp/config.lsp.in
+++ b/src/lsp/config.lsp.in
@@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs."
 (defun lisp-implementation-version ()
   "Args:()
 Returns the version of your ECL as a string."
-  "@PACKAGE_VERSION@ (CVS 2008-04-22 12:25)")
+  "@PACKAGE_VERSION@ (CVS 2008-04-22 14:29)")
 
 (defun machine-type ()
   "Args: ()