From 1801c64bff514bc50a956003ed1558ef2ecdab5c Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 5 Jun 2011 12:35:35 +0200 Subject: [PATCH] Dedicated function for loaded bytecompiled files --- contrib/bytecmp/bytecmp.lsp | 22 ++++++------- src/c/load.d | 64 +++++++++++++++++++++++++++++++++++++ src/c/main.d | 4 +-- src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/h/external.h | 1 + 6 files changed, 82 insertions(+), 13 deletions(-) diff --git a/contrib/bytecmp/bytecmp.lsp b/contrib/bytecmp/bytecmp.lsp index f8ba38c3c..9e4edf3c1 100644 --- a/contrib/bytecmp/bytecmp.lsp +++ b/contrib/bytecmp/bytecmp.lsp @@ -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)) diff --git a/src/c/load.d b/src/c/load.d index f60749644..0bb7eb0fb 100755 --- a/src/c/load.d +++ b/src/c/load.d @@ -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*')) diff --git a/src/c/main.d b/src/c/main.d index f5cd8a2cc..977d3dfcb 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -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(); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 1edbf91de..1a98b003c 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index b3e201f4a..d1be65494 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -2049,5 +2049,7 @@ cl_symbols[] = { {KEY_ "RESOLVE-SYMLINKS",NULL}, +{SYS_ "LOAD-BYTECODES","si_load_bytecodes"}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/h/external.h b/src/h/external.h index 0ab99e68a..139042c6c 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -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, ...));