mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-30 14:20:41 -08:00
Code Issues Projects Releases Packages Wiki Activity

Added hooks for registering DEF* forms and their locations with some database.

Browse source
This commit is contained in:
jjgarcia 2008-07-12 14:13:05 +00:00
parent 6c788d733e
commit 250b294aaa
13 changed files with 52 additions and 75 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/Makefile.in
View file

@ -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

2
src/c/compiler.d
View file

@ -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;

5
src/c/load.d
View file

@ -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 {

9
src/c/symbols_list.h
View file

@ -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},

9
src/c/symbols_list2.h
View file

@ -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},

6
src/clos/defclass.lsp
View file

@ -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

13
src/clos/generic.lsp
View file

@ -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))

21
src/clos/method.lsp
View file

@ -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))))))
;;; ----------------------------------------------------------------------

24
src/lsp/autoload.lsp
View file

@ -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\"."

2
src/lsp/defmacro.lsp
View file

@ -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:

3
src/lsp/defstruct.lsp
View file

@ -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))

18
src/lsp/evalmacros.lsp
View file

@ -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)

13
src/lsp/export.lsp
View file

@ -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)