mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-06 02:40:26 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'fix-571' into 'develop'

Browse source 
Fix 571

Closes #571

See merge request embeddable-common-lisp/ecl!195
This commit is contained in:
Marius Gerbershagen 2020-04-09 16:51:47 +00:00
commit abe2a2811f
10 changed files with 105 additions and 89 deletions
Download patch file Download diff file Expand all files Collapse all files

113
src/c/compiler.d
View file

@ -2198,34 +2198,6 @@ c_values(cl_env_ptr env, cl_object args, int flags) {
return FLAG_VALUES;
}
static int
need_to_make_load_form_p(cl_object o)
{
switch (ecl_t_of(o)) {
case t_character:
case t_fixnum:
case t_bignum:
case t_ratio:
case t_singlefloat:
case t_doublefloat:
case t_longfloat:
case t_complex:
case t_symbol:
case t_pathname:
#ifdef ECL_UNICODE
case t_string:
#endif
case t_base_string:
case t_bitvector:
return 0;
case t_list:
if (Null(o)) return 0;
default:
return _ecl_funcall3(@'clos::need-to-make-load-form-p', o, ECL_NIL)
!= ECL_NIL;
}
}
static void
maybe_make_load_forms(cl_env_ptr env, cl_object constant)
{
@ -2235,7 +2207,7 @@ maybe_make_load_forms(cl_env_ptr env, cl_object constant)
return;
if (c_search_constant(env, constant) >= 0)
return;
if (!need_to_make_load_form_p(constant))
if (si_need_to_make_load_form_p(constant) == ECL_NIL)
return;
make = _ecl_funcall2(@'make-load-form', constant);
init = (env->nvalues > 1)? env->values[1] : ECL_NIL;
@ -2665,6 +2637,89 @@ c_listA(cl_env_ptr env, cl_object args, int flags)
------------------------------------------------------------ */
/*
Determine whether the form can be externalized using the lisp
printer or we should rather use MAKE-LOAD-FORM.
*/
cl_object
si_need_to_make_load_form_p(cl_object object)
{
cl_object load_form_cache = ECL_NIL;
cl_object waiting_objects = ecl_list1(object);
cl_type type = t_start;
loop:
if (waiting_objects == ECL_NIL)
return ECL_NIL;
object = pop(&waiting_objects);
type = ecl_t_of(object);
/* For simple, atomic objects we just return NIL. There is no need
to call MAKE-LOAD-FORM on them. */
switch (type) {
case t_character:
case t_fixnum:
case t_bignum:
case t_ratio:
case t_singlefloat:
case t_doublefloat:
case t_longfloat:
case t_complex:
#ifdef ECL_COMPLEX_FLOAT
case t_csfloat:
case t_cdfloat:
case t_clfloat:
#endif
case t_symbol:
case t_pathname:
#ifdef ECL_UNICODE
case t_string:
#endif
case t_base_string:
case t_bitvector:
goto loop;
case t_list:
if (Null(object)) goto loop;
default:
;
}
/* For compound objects we set up a cache and run through the
objects content looking for components that might require
MAKE-LOAD-FORM to be externalized. The cache is used to solve the
problem of circularity and of EQ references. */
if (ecl_member_eq(object, load_form_cache))
goto loop;
push(object, &load_form_cache);
switch (type) {
case t_array:
case t_vector:
if (object->array.elttype == ecl_aet_object) {
cl_index i = 0;
for(; i<object->array.dim; i++) {
push(object->array.self.t[i], &waiting_objects);
}
}
goto loop;
case t_list:
push(ECL_CONS_CAR(object), &waiting_objects);
push(ECL_CONS_CDR(object), &waiting_objects);
goto loop;
case t_bclosure: {
cl_object bc = object->bclosure.code;;
push(object->bclosure.lex, &waiting_objects);
push(bc->bytecodes.data, &waiting_objects);
push(bc->bytecodes.name, &waiting_objects);
goto loop;
}
case t_bytecodes:
push(object->bytecodes.data, &waiting_objects);
push(object->bytecodes.name, &waiting_objects);
goto loop;
default:
return ECL_T;
}
_ecl_unexpected_return();
}
/*
Handles special declarations, removes declarations from body
*/

2
src/c/symbols_list.h
View file

@ -1214,6 +1214,7 @@ cl_symbols[] = {
{SYS_ "MEMQ", SI_ORDINARY, si_memq, 2, OBJNULL},
{SYS_ "MKDIR", SI_ORDINARY, si_mkdir, 2, OBJNULL},
{EXT_ "MKSTEMP", EXT_ORDINARY, si_mkstemp, 1, OBJNULL},
{SYS_ "NEED-TO-MAKE-LOAD-FORM-P", SI_ORDINARY, si_need_to_make_load_form_p, 1, OBJNULL},
{SYS_ "RMDIR", SI_ORDINARY, si_rmdir, 1, OBJNULL},
{EXT_ "MAKE-PIPE", EXT_ORDINARY, si_make_pipe, 0, OBJNULL},
/* package extensions */
@ -1776,7 +1777,6 @@ cl_symbols[] = {
{CLOS_ "VALIDATE-SUPERCLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "WRITER-METHOD-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "CLEAR-GFUN-HASH", SI_ORDINARY, si_clear_gfun_hash, 1, OBJNULL},
{CLOS_ "NEED-TO-MAKE-LOAD-FORM-P", CLOS_ORDINARY, ECL_NAME(clos_need_to_make_load_form_p), 2, OBJNULL},
{CLOS_ "LOAD-DEFCLASS", CLOS_ORDINARY, ECL_NAME(clos_load_defclass), 4, OBJNULL},
{CLOS_ "DOCSTRING", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "SAFE-INSTANCE-REF", CLOS_ORDINARY, clos_safe_instance_ref, 2, OBJNULL},

2
src/c/symbols_list2.h
View file

@ -1214,6 +1214,7 @@ cl_symbols[] = {
{SYS_ "MEMQ","si_memq",2},
{SYS_ "MKDIR","si_mkdir",2},
{EXT_ "MKSTEMP","si_mkstemp",1},
{SYS_ "NEED-TO-MAKE-LOAD-FORM-P","si_need_to_make_load_form_p",1},
{SYS_ "RMDIR","si_rmdir",1},
{EXT_ "MAKE-PIPE","si_make_pipe",0},
/* package extensions */
@ -1776,7 +1777,6 @@ cl_symbols[] = {
{CLOS_ "VALIDATE-SUPERCLASS",NULL,-1},
{CLOS_ "WRITER-METHOD-CLASS",NULL,-1},
{SYS_ "CLEAR-GFUN-HASH","si_clear_gfun_hash",1},
{CLOS_ "NEED-TO-MAKE-LOAD-FORM-P","ECL_NAME(clos_need_to_make_load_form_p)",2},
{CLOS_ "LOAD-DEFCLASS","ECL_NAME(clos_load_defclass)",4},
{CLOS_ "DOCSTRING",NULL,-1},
{CLOS_ "SAFE-INSTANCE-REF","clos_safe_instance_ref",2},

3
src/clos/method.lsp
View file

@ -251,8 +251,7 @@
;; explicitely the bytecodes compiler with an environment, no
;; stepping, compiler-env-p = t and execute = nil, so that the
;; form does not get executed.
;; FIXME: Why is execute t then?
(si::eval-with-env method-lambda env nil t t)))
(si::eval-with-env method-lambda env nil t nil)))
(values call-next-method-p
next-method-p-p
in-closure-p)))

51
src/clos/print.lsp
View file

@ -51,57 +51,12 @@
(primitive-nil))
initialization-form)))))))
(defun need-to-make-load-form-p (object env)
"Return T if the object cannot be externalized using the lisp
printer and we should rather use MAKE-LOAD-FORM."
(declare (ignore env))
(let ((*load-form-cache* nil))
(declare (special *load-form-cache*))
(labels ((recursive-test (object)
(loop
;; For simple, atomic objects we just return NIL. There is no need to
;; call MAKE-LOAD-FORM on them
(when (typep object '(or character number symbol pathname string bit-vector))
(return nil))
;; For complex objects we set up a cache and run through the
;; objects content looking for data that might require
;; MAKE-LOAD-FORM to be externalized. The cache is used to
;; solve the problem of circularity and of EQ references.
(unless *load-form-cache*
(setf *load-form-cache* (make-hash-table :size 128 :test #'eq)))
(when (gethash object *load-form-cache*)
(return nil))
(setf (gethash object *load-form-cache*) t)
(cond ((arrayp object)
(unless (subtypep (array-element-type object) '(or character number))
(dotimes (i (array-total-size object))
(recursive-test (row-major-aref object i))))
(return nil))
((consp object)
(recursive-test (car object))
(setf object (rest object)))
((compiled-function-p object)
(multiple-value-bind (lex code data name)
(si::bc-split object)
(when (or (null data)
(null code)
(recursive-test lex)
(recursive-test code)
(recursive-test name))
(throw 'need-to-make-load-form t))
(setf object data)))
(t
(throw 'need-to-make-load-form t))))))
(catch 'need-to-make-load-form
(recursive-test object)
nil))))
(defmethod make-load-form ((object t) &optional env)
(flet ((maybe-quote (object)
(if (or (consp object) (symbolp object))
(list 'quote object)
object)))
(unless (need-to-make-load-form-p object env)
(unless (si::need-to-make-load-form-p object)
(return-from make-load-form (maybe-quote object)))
(typecase object
(compiled-function
@ -121,7 +76,7 @@ printer and we should rather use MAKE-LOAD-FORM."
:initial-contents
',(loop for i from 0 below (array-total-size object)
collect (let ((x (row-major-aref object i)))
(if (need-to-make-load-form-p x env)
(if (si::need-to-make-load-form-p x)
(progn (push `(setf (row-major-aref ,object ,i) ',x)
init-forms)
0)
@ -140,7 +95,7 @@ printer and we should rather use MAKE-LOAD-FORM."
:rehash-size ,(hash-table-rehash-size object)
:rehash-threshold ,(hash-table-rehash-threshold object)
:test ',(hash-table-test object))))
(if (need-to-make-load-form-p content env)
(if (si::need-to-make-load-form-p content)
(values
make-form
`(dolist (i ',(loop for key being each hash-key in object

2
src/cmp/cmpwt.lsp
View file

@ -155,7 +155,7 @@
(add-object 0 :duplicate t :permanent t))
(defun add-load-form (object location)
(unless (clos::need-to-make-load-form-p object *cmp-env*)
(unless (si::need-to-make-load-form-p object)
(return-from add-load-form))
(unless (eq *compiler-phase* 't1)
(cmperr "Unable to internalize complex object ~A in ~a phase." object *compiler-phase*))

2
src/cmp/proclamations.lsp
View file

@ -1451,7 +1451,7 @@
(proclamation clos::associate-methods-to-gfun (function-name *)
generic-function)
#+clos
(proclamation clos::need-to-make-load-form-p (t t) gen-bool :pure)
(proclamation si::need-to-make-load-form-p (t) gen-bool :pure)
#+clos
(proclamation clos::load-defclass (t t t t) t)

2
src/cmp/sysfun.lsp
View file

@ -1035,8 +1035,6 @@
clos:extract-specializer-names
;; predlib.lsp
si::subclassp si::of-class-p
;; print.lsp
clos::need-to-make-load-form-p
;; slotvalue.lsp
slot-makunbound
;; std-slot-value.lsp

4
src/h/external.h
View file

@ -522,6 +522,7 @@ extern ECL_API cl_object cl_grab_rest_args(ecl_va_list args);
/* compiler.c */
extern ECL_API cl_object si_macrolet_function(cl_object form, cl_object env);
extern ECL_API cl_object si_need_to_make_load_form_p(cl_object object);
extern ECL_API cl_object si_process_lambda_list(cl_object lambda_list, cl_object context);
extern ECL_API cl_object si_process_lambda(cl_object lambda);
extern ECL_API cl_object si_make_lambda(cl_object name, cl_object body);
@ -2207,9 +2208,6 @@ extern ECL_API cl_object cl_slot_boundp(cl_object object, cl_object slot);
extern ECL_API cl_object cl_slot_makunbound(cl_object object, cl_object slot);
extern ECL_API cl_object cl_slot_exists_p(cl_object object, cl_object slot);
/* print.lsp */
extern ECL_API cl_object clos_need_to_make_load_form_p(cl_object o, cl_object env);
/* defclass.lsp */
extern ECL_API cl_object clos_load_defclass(cl_object name, cl_object superclasses, cl_object slots, cl_object options);

13
src/tests/normal-tests/compiler.lsp
View file

@ -655,7 +655,7 @@
(subst 3 l l)
(make-instance 'compiler-test-class)
(subst (make-instance 'compiler-test-class) 3 l)))
collect (clos::need-to-make-load-form-p object nil))
collect (si::need-to-make-load-form-p object))
'(nil nil t t))))
;;; Date: 18/05/2005
@ -1744,3 +1744,14 @@
(is (eq (peer* v1) v2))
(is (eq (peer* v2) v1)))))))
;;; Date 2020-03-13
;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/571
;;; Description
;;;
;;; LOAD-TIME-VALUE inside a DEFMETHOD is evaluated at the
;;; compilation time.
(test cmp.0078.defmethod-not-eager
(finishes (with-compiler ("aux-compiler.0078.lsp")
`(defclass class () ())
`(defmethod method ()
(load-time-value (find-class class))))))