mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-30 04:10:44 -08:00
Code Issues Projects Releases Packages Wiki Activity

Dedicated function for loaded bytecompiled files

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2011-06-05 12:35:35 +02:00
parent cbcb905d28
commit 1801c64bff
6 changed files with 82 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

22
contrib/bytecmp/bytecmp.lsp
View file

@ -64,17 +64,17 @@
(with-open-file (sin input-pathname :direction :input)
(with-open-file (sout output-file :direction :output :if-exists :supersede
:if-does-not-exist :create)
(loop with *package* = *package*
and ext:*bytecodes-compiler* = t
for form = (read sin nil :EOF)
until (eq form :EOF)
do (handler-case
(let ((bytecodes (si:eval-with-env form nil nil nil nil)))
(with-standard-io-syntax
(write `(FUNCALL ,bytecodes) :stream sout :circle t
:escape t :readably t :pretty nil)
(terpri sout)))
(error (c) (let ((*print-readably* nil) (*print-pretty* nil) (*print-circle* t)) (break)))))))
(handler-case
(sys:with-ecl-io-syntax
(write (loop with *package* = *package*
and ext:*bytecodes-compiler* = t
for form = (read sin nil :EOF)
until (eq form :EOF)
collect (si:eval-with-env form nil nil nil nil))
:stream sout :circle t
:escape t :readably t :pretty nil)
(terpri sout))
(error (c) (let ((*print-readably* nil) (*print-pretty* nil) (*print-circle* t)) (break))))))
(when load
(load output-file :verbose *compile-verbose*))
(values output-file nil nil))

64
src/c/load.d
View file

@ -122,6 +122,70 @@ si_load_source(cl_object source, cl_object verbose, cl_object print, cl_object e
@(return Cnil)
}
cl_object
si_load_bytecodes(cl_object source, cl_object verbose, cl_object print, cl_object external_format)
{
cl_env_ptr env = ecl_process_env();
cl_object forms, strm;
cl_object old_eptbc = env->packages_to_be_created;
/* Source may be either a stream or a filename */
if (type_of(source) != t_pathname && type_of(source) != t_base_string) {
/* INV: if "source" is not a valid stream, file.d will complain */
strm = source;
} else {
strm = ecl_open_stream(source, smm_input, Cnil, Cnil, 8,
ECL_STREAM_C_STREAM, external_format);
if (Null(strm))
@(return Cnil)
}
CL_UNWIND_PROTECT_BEGIN(env) {
{
cl_object progv_list = ECL_SYM_VAL(env, @'si::+ecl-syntax-progv-list+');
cl_index bds_ndx = ecl_progv(env, ECL_CONS_CAR(progv_list),
ECL_CONS_CDR(progv_list));
env->packages_to_be_created_p = Ct;
forms = cl_read(1, strm);
env->packages_to_be_created_p = Cnil;
ecl_bds_unwind(env, bds_ndx);
}
while (!Null(forms)) {
if (ECL_LISTP(forms)) {
cl_object x = ECL_CONS_CAR(forms);
forms = ECL_CONS_CDR(forms);
if (type_of(x) == t_bytecodes) {
cl_funcall(1, x);
continue;
}
}
FEerror("Corrupt bytecodes file ~S", 1, source);
}
{
cl_object x;
x = cl_set_difference(2, env->packages_to_be_created, old_eptbc);
old_eptbc = env->packages_to_be_created;
unlikely_if (!Null(x)) {
CEerror(Ct,
Null(ECL_CONS_CDR(x))?
"Package ~A referenced in "
"compiled file~& ~A~&but has not been created":
"The packages~& ~A~&were referenced in "
"compiled file~& ~A~&but have not been created",
2, x, source);
}
}
} 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
try to close the stream, and then jump to next catch
point */
if (strm != source)
cl_close(3, strm, @':abort', @'t');
} CL_UNWIND_PROTECT_END;
@(return Cnil)
}
@(defun load (source
&key (verbose ecl_symbol_value(@'*load-verbose*'))
(print ecl_symbol_value(@'*load-print*'))

4
src/c/main.d
View file

@ -659,8 +659,8 @@ cl_boot(int argc, char **argv)
CONS(str_lisp, @'si::load-source'),
CONS(str_LSP, @'si::load-source'),
CONS(str_LISP, @'si::load-source'),
CONS(str_fasc, @'si::load-source'),
CONS(str_FASC, @'si::load-source'),
CONS(str_fasc, @'si::load-bytecodes'),
CONS(str_FASC, @'si::load-bytecodes'),
CONS(Cnil, @'si::load-source'));
ECL_SET(@'si::*load-hooks*', aux);
init_error();

2
src/c/symbols_list.h
View file

@ -2049,5 +2049,7 @@ cl_symbols[] = {
{KEY_ "RESOLVE-SYMLINKS", KEYWORD, NULL, -1, OBJNULL},
{SYS_ "LOAD-BYTECODES", SI_ORDINARY, si_load_bytecodes, 4, OBJNULL},
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

2
src/c/symbols_list2.h
View file

@ -2049,5 +2049,7 @@ cl_symbols[] = {
{KEY_ "RESOLVE-SYMLINKS",NULL},
{SYS_ "LOAD-BYTECODES","si_load_bytecodes"},
/* Tag for end of list */
{NULL,NULL}};

1
src/h/external.h
View file

@ -924,6 +924,7 @@ extern ECL_API cl_object ecl_delete_eq(cl_object x, cl_object l);
/* load.c */
extern ECL_API cl_object si_load_bytecodes(cl_object file, cl_object verbose, cl_object print, cl_object format);
extern ECL_API cl_object si_load_source(cl_object file, cl_object verbose, cl_object print, cl_object format);
extern ECL_API cl_object si_load_binary(cl_object file, cl_object verbose, cl_object print, cl_object format);
extern ECL_API cl_object cl_load _ARGS((cl_narg narg, cl_object pathname, ...));