From 250b294aaa47c092b3f0e3e8ac7a846cf063d623 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 12 Jul 2008 14:13:05 +0000 Subject: [PATCH] Added hooks for registering DEF* forms and their locations with some database. --- src/c/Makefile.in | 2 +- src/c/compiler.d | 2 +- src/c/load.d | 5 +++-- src/c/symbols_list.h | 9 +++------ src/c/symbols_list2.h | 9 +++------ src/clos/defclass.lsp | 6 ++++-- src/clos/generic.lsp | 13 ++++++------- src/clos/method.lsp | 21 ++++++--------------- src/lsp/autoload.lsp | 24 ------------------------ src/lsp/defmacro.lsp | 2 +- src/lsp/defstruct.lsp | 3 ++- src/lsp/evalmacros.lsp | 18 ++++++++++-------- src/lsp/export.lsp | 13 ++++++++++++- 13 files changed, 52 insertions(+), 75 deletions(-) diff --git a/src/c/Makefile.in b/src/c/Makefile.in index aedadc281..89f1be1e2 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -72,7 +72,7 @@ ffi_x86_64.c: arch/ffi_x86_64.d $(DPP) $(HFILES) $(RANLIB) $@ clean: - $(RM) dpp *.c *.h $(OBJS) ../libecl.a cinit.o core a.out + $(RM) $(DPP) *.c *.h $(OBJS) all_symbols.o all_symbols2.o ../libecl.a cinit.o core a.out # Build rules diff --git a/src/c/compiler.d b/src/c/compiler.d index 07f3e4da7..7e2cd9f19 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -155,7 +155,7 @@ asm_end(cl_index beginning) { cl_index code_size, data_size, i; cl_opcode *code; cl_object file = SYM_VAL(@'*load-truename*'); - cl_object position = SYM_VAL(@'ext::*load-position*'); + cl_object position = cl_cdr(SYM_VAL(@'ext::*source-location*')); /* Save bytecodes from this session in a new vector */ code_size = current_pc() - beginning; diff --git a/src/c/load.d b/src/c/load.d index d615c832a..59bbe3c16 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -393,7 +393,8 @@ si_load_source(cl_object source, cl_object verbose, cl_object print) } CL_UNWIND_PROTECT_BEGIN { cl_object form_index = MAKE_FIXNUM(0); - bds_bind(@'ext::*load-position*', MAKE_FIXNUM(0)); + cl_object location = CONS(source, form_index); + bds_bind(@'ext::*source-location*', location); for (;;) { x = cl_read(3, strm, Cnil, OBJNULL); if (x == OBJNULL) @@ -404,7 +405,7 @@ si_load_source(cl_object source, cl_object verbose, cl_object print) @terpri(0); } form_index = ecl_plus(MAKE_FIXNUM(1),form_index); - ECL_SETQ(@'ext::*load-position*', form_index); + ECL_RPLACD(location, form_index); } bds_unwind1(); } CL_UNWIND_PROTECT_EXIT { diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 72f6d9dea..a44e0972e 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1227,11 +1227,9 @@ cl_symbols[] = { {SYS_ "*PROFILE-ARRAY*", SI_SPECIAL, NULL, -1, OBJNULL}, #endif -#ifdef PDE -{SYS_ "*RECORD-SOURCE-PATHNAME-P*", SI_SPECIAL, NULL, -1, OBJNULL}, -{SYS_ "*SOURCE-PATHNAME*", SI_SPECIAL, NULL, -1, Cnil}, -{SYS_ "RECORD-SOURCE-PATHNAME", SI_ORDINARY, NULL, -1, OBJNULL}, -#endif +{EXT_ "*SOURCE-LOCATION*", EXT_SPECIAL, NULL, -1, Cnil}, +{EXT_ "*REGISTER-WITH-PDE-HOOK*", EXT_SPECIAL, NULL, -1, Cnil}, +{EXT_ "REGISTER-WITH-PDE", EXT_ORDINARY, NULL, -1, OBJNULL}, #ifdef PROFILE {SYS_ "PROFILE", SI_ORDINARY, si_profile, -1, OBJNULL}, @@ -1691,7 +1689,6 @@ 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}, {SYS_ "PROPERTY-LIST", SI_ORDINARY, NULL, 1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 6bf64b152..aadf46d3d 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1227,11 +1227,9 @@ cl_symbols[] = { {SYS_ "*PROFILE-ARRAY*",NULL}, #endif -#ifdef PDE -{SYS_ "*RECORD-SOURCE-PATHNAME-P*",NULL}, -{SYS_ "*SOURCE-PATHNAME*",NULL}, -{SYS_ "RECORD-SOURCE-PATHNAME",NULL}, -#endif +{EXT_ "*SOURCE-LOCATION*",NULL}, +{EXT_ "*REGISTER-WITH-PDE-HOOK*",NULL}, +{EXT_ "REGISTER-WITH-PDE",NULL}, #ifdef PROFILE {SYS_ "PROFILE","si_profile"}, @@ -1691,7 +1689,6 @@ cl_symbols[] = { {"LOG1P","si_log1p"}, -{EXT_ "*LOAD-POSITION*",NULL}, {EXT_ "BC-FILE","si_bc_file"}, {SYS_ "PROPERTY-LIST",NULL}, diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index bb415232d..04d421611 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -124,8 +124,10 @@ (list 'quote (rest option))))) (setf options (list* `',option-name option-value options)))) `(eval-when (compile load eval) - (ensure-class ',name :direct-superclasses ',superclasses - :direct-slots ,slots ,@options)))) + ,(ext:register-with-pde form + `(ensure-class ',name :direct-superclasses + ',superclasses + :direct-slots ,slots ,@options))))) ;;; ---------------------------------------------------------------------- ;;; ENSURE-CLASS diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index 53a980100..413a9c8e4 100644 --- a/src/clos/generic.lsp +++ b/src/clos/generic.lsp @@ -15,7 +15,7 @@ ;;; DEFGENERIC ;;; -(defmacro defgeneric (&rest args) +(defmacro defgeneric (&whole whole &rest args) (multiple-value-bind (function-specifier lambda-list options) (parse-defgeneric args) (parse-lambda-list lambda-list) @@ -24,12 +24,11 @@ (parse-generic-options options lambda-list) (let* ((output `(ensure-generic-function ',function-specifier :delete-methods t ,@option-list))) - (if method-list - `(associate-methods-to-gfun ,output - ,@(mapcar #'(lambda (m) `(defmethod ,function-specifier ,@m)) - method-list)) - output)) - ))) + (when method-list + (setf method-list (mapcar #'(lambda (m) `(defmethod ,function-specifier ,@m)) + method-list) + output `(associate-methods-to-gfun ,output ,@method-list))) + (ext:register-with-pde whole output))))) (defun parse-defgeneric (args) (declare (si::c-local)) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index aca955b84..57d73ad5b 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -31,7 +31,7 @@ ;;; DEFMETHOD ;;; -(defmacro defmethod (&rest args &environment env) +(defmacro defmethod (&whole whole &rest args &environment env) (multiple-value-bind (name qualifiers specialized-lambda-list body) (parse-defmethod args) (multiple-value-bind (lambda-list required-parameters specializers) @@ -40,20 +40,11 @@ (expand-defmethod name qualifiers lambda-list required-parameters specializers body env) (declare (ignore required-parameters)) - `(PROGN - #+PDE - (EVAL-WHEN (LOAD) - (SI:RECORD-SOURCE-PATHNAME - ',name '(DEFMETHOD ',qualifiers ',specializers))) - (INSTALL-METHOD - ',name - ',qualifiers - ,(list 'si::quasiquote specializers) - ',lambda-list - ',doc - ',plist - ,fn-form) - ))))) + (ext:register-with-pde whole + `(install-method ',name ',qualifiers + ,(list 'si::quasiquote specializers) + ',lambda-list ',doc + ',plist ,fn-form)))))) ;;; ---------------------------------------------------------------------- diff --git a/src/lsp/autoload.lsp b/src/lsp/autoload.lsp index ef8ea6387..5ac34d765 100644 --- a/src/lsp/autoload.lsp +++ b/src/lsp/autoload.lsp @@ -16,30 +16,6 @@ (in-package "SYSTEM") -#+PDE -(progn -(setq *record-source-pathname-p* nil) -(defun record-source-pathname (symbol type) - ;; type is either: - ;; 1. a symbol, for single entry definitions (defun, defvar, defclass ..) - ;; 2. a list (type . spec), for multiple entries (defmethod) - (when (and *record-source-pathname-p* - *source-pathname*) - (when (sys::setf-namep symbol) - (setq symbol (get-sysprop (second symbol) 'setf-symbol))) - (if (symbolp type) - (put-sysprop symbol *source-pathname* type) - (let* ((alist (get-sysprop symbol (car type))) - (spec (cdr type))) - (if alist - (let ((entry (assoc spec alist :test #'equal))) - (if entry - (setf (cdr entry) *source-pathname*) - (push (cons spec *source-pathname*) alist))) - (setq alist (list (cons spec *source-pathname*)))) - (put-sysprop symbol alist (car type)))))) -) - (defun lisp-implementation-type () "Args: () Returns the string \"ECL\"." diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp index f0e886916..9de121cb1 100644 --- a/src/lsp/defmacro.lsp +++ b/src/lsp/defmacro.lsp @@ -292,7 +292,7 @@ (when *dump-defmacro-definitions* (print function) (setq function `(si::bc-disassemble ,function))) - `(si::fset ',name ,function t ,pprint)))) + (ext:register-with-pde def `(si::fset ',name ,function t ,pprint))))) t) ;;; valid lambda-list to DESTRUCTURING-BIND is: diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index da5b7ca66..f4724d41f 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -326,7 +326,7 @@ ;;; The DEFSTRUCT macro. -(defmacro defstruct (name&opts &rest slots) +(defmacro defstruct (&whole whole name&opts &rest slots) "Syntax: (defstruct {name | (name {:conc-name | (:conc-name prefix-string) | :constructor | (:constructor symbol [lambda-list]) | @@ -504,6 +504,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)." `(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel) ,core + ,(si::register-with-pde whole) ,@(subst `(load-time-value (find-class ',name)) '.structure-constructor-class. constructors)) diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index bf7aaee2c..df139e5bb 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -68,7 +68,7 @@ macro useful for defining macros." ,@(si::expand-set-documentation name 'function doc-string) ',name))) -(defmacro defvar (var &optional (form nil form-sp) doc-string) +(defmacro defvar (&whole whole var &optional (form nil form-sp) doc-string) "Syntax: (defvar name [form [doc]]) Declares the variable named by NAME as a special variable. If the variable does not have a value, then evaluates FORM and assigns the value to the @@ -80,12 +80,12 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." `((UNLESS (BOUNDP ',var) (SETQ ,var ,form)))) ,@(si::expand-set-documentation var 'variable doc-string) - #+PDE (SYS:RECORD-SOURCE-PATHNAME ',var 'defvar) + ,(ext:register-with-pde whole) (eval-when (:compile-toplevel) (si::register-global ',var)) ',var)) -(defmacro defparameter (var form &optional doc-string) +(defmacro defparameter (&whole whole var form &optional doc-string) "Syntax: (defparameter name form [doc]) Declares the global variable named by NAME as a special variable and assigns the value of FORM to the variable. The doc-string DOC, if supplied, is saved @@ -94,15 +94,15 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." (SYS:*MAKE-SPECIAL ',var) (SETQ ,var ,form) ,@(si::expand-set-documentation var 'variable doc-string) - #+PDE (SYS:RECORD-SOURCE-PATHNAME ',var 'DEFPARAMETER) + ,(ext:register-with-pde whole) (eval-when (:compile-toplevel) (si::register-global ',var)) ',var)) -(defmacro defconstant (var form &optional doc-string) +(defmacro defconstant (&whole whole var form &optional doc-string) `(PROGN (SYS:*MAKE-CONSTANT ',var ,form) ,@(si::expand-set-documentation var 'variable doc-string) - #+PDE (SYS:RECORD-SOURCE-PATHNAME ',var 'defconstant) + ,(ext:register-with-pde whole) (eval-when (:compile-toplevel) (si::register-global ',var)) ',var)) @@ -110,7 +110,7 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." ;;; ;;; This is a no-op unless the compiler is installed ;;; -(defmacro define-compiler-macro (name vl &rest body) +(defmacro define-compiler-macro (&whole whole name vl &rest body) (multiple-value-bind (function pprint doc-string) (sys::expand-defmacro name vl body) (setq function `(function ,function)) @@ -120,6 +120,7 @@ as a VARIABLE doc and can be retrieved by (documentation 'NAME 'variable)." `(progn (put-sysprop ',name 'sys::compiler-macro ,function) ,@(si::expand-set-documentation name 'function doc-string) + ,(ext:register-with-pde whole) ',name))) (defun compiler-macro-function (name &optional env) @@ -317,7 +318,7 @@ SECOND-FORM." (declare (ignore type)) value) -(defmacro define-symbol-macro (symbol expansion) +(defmacro define-symbol-macro (&whole whole symbol expansion) (cond ((not (symbolp symbol)) (error "DEFINE-SYMBOL-MACRO: ~A is not a symbol" symbol)) @@ -327,6 +328,7 @@ SECOND-FORM." (t `(progn (put-sysprop ',symbol 'si::symbol-macro (lambda (form env) ',expansion)) + ,(ext:register-with-pde whole) ',symbol)))) (defmacro nth-value (n expr) diff --git a/src/lsp/export.lsp b/src/lsp/export.lsp index fd40e1020..7fe112cc0 100644 --- a/src/lsp/export.lsp +++ b/src/lsp/export.lsp @@ -23,6 +23,17 @@ ;; This is needed only when bootstrapping ECL using ECL-MIN (eval-when (eval) + (si::fset 'ext:register-with-pde + #'(ext::lambda-block ext:register-with-pde (whole env) + (let* ((definition (second whole)) + (output-form (third whole))) + `(if ext:*register-with-pde-hook* + (funcall ext:*register-with-pde-hook* + (copy-tree *source-location*) + ,definition + ,output-form) + ,output-form))) + t) (si::fset 'defun #'(ext::lambda-block defun (def env) (let* ((name (second def)) @@ -30,7 +41,7 @@ (when *dump-defun-definitions* (print function) (setq function `(si::bc-disassemble ,function))) - `(si::fset ',name ,function))) + (ext:register-with-pde def `(si::fset ',name ,function)))) t) (si::fset 'in-package #'(ext::lambda-block in-package (def env)