mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-14 13:21:54 -08:00
Code Issues Projects Releases Packages Wiki Activity

Every file now has an array with the functions it defines.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2008-10-06 22:00:52 +02:00
parent 054989113e
commit edae4ae652
8 changed files with 79 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

12
src/c/cfun.d
View file

@ -164,3 +164,15 @@ si_compiled_function_block(cl_object fun)
}
@(return output)
}
void
ecl_cmp_defmacro(cl_object fun)
{
si_fset(3, fun->cfun.name, fun, Ct);
}
void
ecl_cmp_defun(cl_object fun)
{
si_fset(2, fun->cfun.name, fun);
}

10
src/c/read.d
View file

@ -2138,6 +2138,16 @@ read_VV(cl_object block, void (*entry_point)(cl_object))
if (i < len)
FEreader_error("Not enough data while loading binary file", in, 0);
NO_DATA_LABEL:
for (i = 0; i < block->cblock.cfuns_size; i++) {
struct ecl_cfun *prototype = block->cblock.cfuns+i;
cl_index fname_location = fix(prototype->block);
cl_object fname = VV[fname_location];
cl_index location = fix(prototype->name);
int narg = prototype->narg;
VV[location] = narg<0?
cl_make_cfun_va(prototype->entry, fname, block) :
cl_make_cfun(prototype->entry, fname, block, narg);
}
/* Execute top-level code */
(*entry_point)(MAKE_FIXNUM(0));
x = cl_core.packages_to_be_created;

48
src/clos/streams.lsp
View file

@ -143,7 +143,7 @@
instead of the end of a line. The default method uses repeated
calls to STREAM-READ-CHAR."))
(defgeneric stream-read-sequence (stream seq &optional start end)
(defgeneric stream-read-sequence (stream sequence &optional start end)
(:documentation
"This is like CL:READ-SEQUENCE, but for Gray streams."))
@ -192,7 +192,7 @@
FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to
STREAM-WRITE-CHAR."))
(defgeneric stream-write-sequence (stream seq &optional start end)
(defgeneric stream-write-sequence (stream sequence &optional start end)
(:documentation
"This is like CL:WRITE-SEQUENCE, but for Gray streams."))
@ -450,10 +450,10 @@
;; UNREAD-CHAR
(defmethod stream-unread-char ((stream ansi-stream) c)
(cl:unread-char stream c))
(defmethod stream-unread-char ((stream ansi-stream) character)
(cl:unread-char stream character))
(defmethod stream-unread-char ((stream ansi-stream) c)
(defmethod stream-unread-char ((stream ansi-stream) character)
(bug-or-error stream 'stream-unread-char))
@ -478,7 +478,7 @@
(loop
(let ((ch (stream-read-char stream)))
(cond ((eq ch :eof)
(return (values (shrink-vector res index) t)))
(return (values (si::shrink-vector res index) t)))
(t
(when (char= ch #\newline)
(return (values (shrink-vector res index) nil)))
@ -500,18 +500,18 @@
;; READ-SEQUENCE
(defmethod stream-read-sequence ((stream fundamental-character-input-stream)
seq &optional (start 0) (end nil))
(si::do-read-sequence seq stream start end))
sequence &optional (start 0) (end nil))
(si::do-read-sequence sequence stream start end))
(defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
seq &optional (start 0) (end nil))
(si::do-read-sequence seq stream start end))
sequence &optional (start 0) (end nil))
(si::do-read-sequence sequence stream start end))
(defmethod stream-read-sequence ((stream ansi-stream) seq
(defmethod stream-read-sequence ((stream ansi-stream) sequence
&optional (start 0) (end nil))
(si:do-read-sequence stream seq start end))
(si:do-read-sequence stream sequence start end))
(defmethod stream-read-sequence ((stream t) seq &optional start end)
(defmethod stream-read-sequence ((stream t) sequence &optional start end)
(bug-or-error stream 'stream-read-sequence))
@ -526,7 +526,7 @@
(defmethod streamp ((stream stream))
t)
(defmethod streamp ((no-stream t))
(defmethod streamp ((stream t))
nil)
@ -541,27 +541,27 @@
;; WRITE-CHAR
(defmethod stream-write-char ((stream ansi-stream) c)
(cl:write-char stream c))
(defmethod stream-write-char ((stream ansi-stream) character)
(cl:write-char stream character))
(defmethod stream-write-char ((stream t) c)
(defmethod stream-write-char ((stream t) character)
(bug-or-error stream 'stream-write-char))
;; WRITE-SEQUENCE
(defmethod stream-write-sequence ((stream fundamental-character-output-stream) seq
(defmethod stream-write-sequence ((stream fundamental-character-output-stream) sequence
&optional (start 0) end)
(si::do-write-sequence seq stream start end))
(si::do-write-sequence sequence stream start end))
(defmethod stream-write-sequence ((stream fundamental-binary-output-stream) seq
(defmethod stream-write-sequence ((stream fundamental-binary-output-stream) sequence
&optional (start 0) end)
(si::do-write-sequence seq stream start end))
(si::do-write-sequence sequence stream start end))
(defmethod stream-write-sequence ((stream ansi-stream) seq &optional (start 0) end)
(si::do-write-sequence seq stream start end))
(defmethod stream-write-sequence ((stream ansi-stream) sequence &optional (start 0) end)
(si::do-write-sequence sequence stream start end))
(defmethod stream-write-sequence ((stream t) seq &optional start end)
(defmethod stream-write-sequence ((stream t) sequence &optional start end)
(bug-or-error stream 'stream-write-sequence))

1
src/cmp/cmpdefs.lsp
View file

@ -514,6 +514,7 @@ lines are inserted, but the order is preserved")
(defvar *global-var-objects* nil) ; var objects for global/special vars
(defvar *global-vars* nil) ; variables declared special
(defvar *global-funs* nil) ; holds { fun }*
(defvar *global-cfuns-array* nil) ; holds { fun }*
(defvar *linking-calls* nil) ; holds { ( global-fun-name fun symbol c-fun-name var-name ) }*
(defvar *local-funs* nil) ; holds { fun }*
(defvar *top-level-forms* nil) ; holds { top-level-form }*

1
src/cmp/cmpenv.lsp
View file

@ -36,6 +36,7 @@
(*global-var-objects* nil)
(*global-vars* nil)
(*global-funs* nil)
(*global-cfuns-array* nil)
(*linking-calls* nil)
(*global-entries* nil)
(*undefined-vars* nil)

43
src/cmp/cmptop.lsp
View file

@ -145,6 +145,8 @@
(wt-nl "flag->cblock.temp_data_size = VMtemp;")
(wt-nl "flag->cblock.data_text = compiler_data_text;")
(wt-nl "flag->cblock.data_text_size = compiler_data_text_size;")
(wt-nl "flag->cblock.cfuns_size = compiler_cfuns_size;")
(wt-nl "flag->cblock.cfuns = compiler_cfuns;")
(wt-nl "return;}")
(wt-nl "#ifdef ECL_DYNAMIC_VV")
(wt-nl "VV = Cblock->cblock.data;")
@ -194,6 +196,8 @@
(wt-nl-h "#else")
(wt-nl-h "static cl_object VV[VM];")
(wt-nl-h "#endif"))))
(wt-nl-h "#define compiler_cfuns_size " (length *global-cfuns-array*))
(wt-nl-h "static const struct ecl_cfun compiler_cfuns[" (length *global-cfuns-array*) "];")
(dolist (l *linking-calls*)
(let* ((c-name (fourth l))
(var-name (fifth l)))
@ -212,6 +216,8 @@
(wt-nl1 "static cl_object " c-name "(cl_narg narg, ...)"
"{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}")))
(output-cfuns *compiler-output1*)
(setq *compiler-phase* 't3)
;;; Callbacks
@ -224,7 +230,6 @@
(wt-nl-h "}")
(wt-nl-h "#endif")
(wt-nl top-output-string))
(defun c1eval-when (args)
@ -653,11 +658,13 @@
(return-from c1fset
(make-c1form* 'SI:FSET :args fun-object nil nil nil nil)))
(when (and (typep macro 'boolean)
(typep pprint '(or integer null)))
(typep pprint '(or integer null))
(consp fname)
(eq (first fname) 'quote))
(return-from c1fset
(make-c1form* 'SI:FSET :args
fun-object ;; Function object
(c1expr fname)
(add-object (second fname) :permanent t :duplicate t)
macro
pprint
;; The c1form, when we do not optimize
@ -680,23 +687,27 @@
(return-from c2fset
(c2call-global 'SI:FSET c1forms 'NIL
(c1form-primary-type (second c1forms)))))
(let* ((*inline-blocks* 0)
(fname (first (coerce-locs (inline-args (list fname)))))
(cfun (fun-cfun fun))
(minarg (fun-minarg fun))
(maxarg (fun-maxarg fun))
(narg (if (= minarg maxarg) maxarg nil)))
(let ((*inline-blocks* 0)
(loc (data-empty-loc)))
(push (list loc fname fun) *global-cfuns-array*)
;; FIXME! Look at c2function!
(new-local fun)
(if macro
(if narg
(wt-nl "cl_def_c_macro(" fname ",(void*)" cfun "," narg ");")
(wt-nl "cl_def_c_macro(" fname ",(void*)" cfun ",-1);"))
(if narg
(wt-nl "cl_def_c_function(" fname ",(void*)" cfun "," narg ");")
(wt-nl "cl_def_c_function_va(" fname ",(void*)" cfun ");")))
(wt-nl (if macro "ecl_cmp_defmacro(" "ecl_cmp_defun(")
loc ");")
(close-inline-blocks)))
(defun output-cfuns (stream)
(format stream "~%static const struct ecl_cfun compiler_cfuns[] = {~
~%~t/*t,m,narg,padding,name,entry,block*/");
(loop for (loc fname-loc fun) in (nreverse *global-cfuns-array*)
do (let* ((cfun (fun-cfun fun))
(minarg (fun-minarg fun))
(maxarg (fun-maxarg fun))
(narg (if (= minarg maxarg) maxarg nil)))
(format stream "~%{0,0,~D,0,MAKE_FIXNUM(~D),(cl_objectfn)~A,MAKE_FIXNUM(~D)},"
(or narg -1) (second loc) cfun (second fname-loc))))
(format stream "~%};"))
;;; ----------------------------------------------------------------------
;;; Pass 1 top-levels.

2
src/h/external.h
View file

@ -336,6 +336,8 @@ extern ECL_API cl_object cl_make_cclosure_va(void *c_function, cl_object env, cl
extern ECL_API void cl_def_c_function(cl_object sym, void *c_function, int narg);
extern ECL_API void cl_def_c_macro(cl_object sym, void *c_function, int narg);
extern ECL_API void cl_def_c_function_va(cl_object sym, void *c_function);
extern ECL_API void ecl_cmp_defmacro(cl_object data);
extern ECL_API void ecl_cmp_defun(cl_object data);
/* character.c */

2
src/h/object.h
View file

@ -552,6 +552,8 @@ struct ecl_codeblock {
cl_object next; /* next codeblock within same library */
cl_object name;
cl_object links; /* list of symbols with linking calls */
cl_index cfuns_size; /* number of functions defined */
const struct ecl_cfun *cfuns;
};
struct ecl_bytecodes {