diff --git a/src/CHANGELOG b/src/CHANGELOG index 5000ddc51..3bbc91c7c 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -31,7 +31,15 @@ ECL 9.1.0: - (SXHASH -0.0) != (SXHASH 0.0) - - In DEFCLASS, the :type of slots was ignored. +* AMOP: + + - In DEFCLASS, the :TYPE of slots was ignored. + + - ECL now sets the proper value for the SLOT-DEFINITION-INITFUNCTION and + SLOT-DEFINITION-INITFORM of each effective and direct slot definition. + + - The canonicalized default arguments list now contains functions instead + of the forms to be evaluated. ;;; Local Variables: *** ;;; mode:text *** diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index e223eefc9..7b66c45e3 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1722,5 +1722,11 @@ cl_symbols[] = { {EXT_ "STORAGE-EXHAUSTED", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "CONSTANTLY-T", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "CONSTANTLY-NIL", EXT_ORDINARY, NULL, -1, OBJNULL}, + +{EXT_ "MAYBE-QUOTE", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "MAYBE-UNQUOTE", EXT_ORDINARY, NULL, -1, 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 e51559a95..bc4179d3f 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1722,5 +1722,11 @@ cl_symbols[] = { {EXT_ "STORAGE-EXHAUSTED",NULL}, +{EXT_ "CONSTANTLY-T",NULL}, +{EXT_ "CONSTANTLY-NIL",NULL}, + +{EXT_ "MAYBE-QUOTE",NULL}, +{EXT_ "MAYBE-UNQUOTE",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index 295cd03c4..bb12fc744 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -24,36 +24,6 @@ (member form '(t nil +initform-unsupplied+)) (and (boundp form) (constantp form) (eq (symbol-value form) form))))) -(defun make-function-initform (form) - ;; INITFORM is a form that is to be evaluated at runtime. If it is a - ;; constant value, we output simply a quoted form. If it is not, - ;; we output a function that can be invoked at runtime to retrieve - ;; the value. - ;; - ;; Output => (FUNCTION (LAMBDA () form)) - ;; => (QUOTE ...) - ;; - (flet ((enclose (form) `#'(lambda () ,form))) - (cond - ;; We generate function for non constant forms - ((not (constantp form)) - (enclose form)) - ;; Constants other than functions become quoted - ((and (not (functionp form)) - (self-evaluating-p form)) - (list 'quote form)) - ;; Quoted forms with arguments which are not functions are - ;; output as such. (the check for functions is weird, but we are - ;; paranoid anyway) - ((and (consp form) - (eq (first form) 'quote) - (not (functionp (second form)))) - form) - ;; All other stuff, including symbols other than keywords, T and NIL - ;; gets in a function form - (t - (enclose form))))) - (defun parse-default-initargs (default-initargs) (declare (si::c-local)) (do* ((output-list nil) @@ -94,16 +64,15 @@ ((endp l) (setf slots (if (every #'constantp slots) - (list 'quote (mapcar #'si::maybe-unquote slots)) + (ext:maybe-quote (mapcar #'ext:maybe-unquote slots)) `(list ,@slots)))) (let* ((slotd (first l)) - (initform (make-function-initform (getf slotd :initform +initform-unsupplied+)))) - (if (eq (first initform) 'QUOTE) - (setf (getf slotd :initform) (second initform) - slotd (list 'quote slotd)) - (setf slotd (mapcar #'(lambda (x) `',x) slotd) - (getf slotd :initform) initform - slotd (list* 'list slotd))) + (initfun (getf slotd :initfunction nil))) + (if initfun + (progn + (remf slotd :initfunction) + (setf slotd (list* 'list :initfunction initfun (mapcar #'ext:maybe-quote slotd)))) + (setf slotd (ext:maybe-quote slotd))) (setf (first l) slotd))) (dolist (option args) (let ((option-name (first option)) @@ -116,13 +85,13 @@ (setq option-value (case option-name ((:metaclass :documentation) - (list 'quote (second option))) + (ext:maybe-quote (second option))) (:default-initargs (setf option-name :direct-default-initargs) (parse-default-initargs (rest option))) (otherwise - (list 'quote (rest option))))) - (setf options (list* `',option-name option-value options)))) + (ext:maybe-quote (rest option))))) + (setf options (list* (ext:maybe-quote option-name) option-value options)))) `(eval-when (compile load eval) ,(ext:register-with-pde form `(ensure-class ',name :direct-superclasses diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index 73337fafa..6208539c9 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.lsp @@ -46,6 +46,8 @@ (defun make-simple-slotd (&key name (initform +initform-unsupplied+) initfunction (type 'T) (allocation :instance) initargs readers writers documentation location) + (when (listp initfunction) + (setf initfunction (eval initfunction))) (list name initform initfunction type allocation initargs readers writers documentation location)) (defun canonical-slot-to-direct-slot (class slotd) @@ -74,6 +76,22 @@ ;;; a slot in DEFCLASS. ;;; +(defun make-function-initform (form) + ;; INITFORM is a form that is to be evaluated at runtime. If it is a + ;; constant value, we output simply a quoted form. If it is not, + ;; we output a function that can be invoked at runtime to retrieve + ;; the value. + ;; + ;; Output => (FUNCTION (LAMBDA () form)) + ;; => (QUOTE ...) + ;; + (if (constantp form) + (let ((value (eval form))) + (cond ((null value) ''si::constantly-nil) + ((eq value t) ''si::constantly-t) + (t `(constantly ,form)))) + `#'(lambda () ,form))) + (defun parse-slot (slot &optional (full nil)) (declare (si::c-local)) (if (symbolp slot) @@ -101,16 +119,17 @@ slot option)) (case option (:initarg (push value (getf output :initargs))) - (:initform (setf (getf output :initform) value) - (setf (getf output :initfunction) nil)) + (:initform (setf (getf output :initform) value + (getf output :initfunction) + (make-function-initform value))) (:accessor (push value (getf output :readers)) (push `(setf ,value) (getf output :writers))) (:reader (push value (getf output :readers))) (:writer (push value (getf output :writers))) - (:allocation (push value (getf output :allocation))) + (:allocation (setf (getf output :allocation) value)) (:type (setf (getf output :type) value)) (:documentation (push value (getf output :documentation))) - (otherwise (setf extra (list* value output extra))))))))) + (otherwise (setf extra (list* value option extra))))))))) (defun parse-slots (slots) (do ((scan slots (cdr scan)) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index dcb215ef0..2a36df10e 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -71,11 +71,9 @@ (or (eq slot-names 'T) (member slot-name slot-names)) (not (slot-boundp instance slot-name))) - (let ((initform (slot-definition-initform slotd))) - (unless (eq initform '+INITFORM-UNSUPPLIED+) - (when (functionp initform) - (setq initform (funcall initform))) - (setf (slot-value instance slot-name) initform))))) + (let ((initfun (slot-definition-initfunction slotd))) + (when initfun + (setf (slot-value instance slot-name) (funcall initfun)))))) ))) instance) @@ -131,7 +129,7 @@ (eq supplied-value 'si::failed)) (when (eq supplied-value '+initform-unsupplied+) (remf initargs initarg)) - (setf value (if (functionp value) (funcall value) value) + (setf value (funcall value) initargs (append initargs (list initarg value)))))) initargs) @@ -365,8 +363,11 @@ because it contains a reference to the undefined class~% ~A" (setf (slot-definition-initargs new-slotd) (union (slot-definition-initargs new-slotd) (slot-definition-initargs old-slotd))) - (when (eq (slot-definition-initform new-slotd) '+INITFORM-UNSUPPLIED+) - (setf (slot-definition-initform new-slotd) (slot-definition-initform old-slotd))) + (unless (slot-definition-initfunction new-slotd) + (setf (slot-definition-initform new-slotd) + (slot-definition-initform old-slotd) + (slot-definition-initfunction new-slotd) + (slot-definition-initfunction old-slotd))) (setf (slot-definition-readers new-slotd) (union (slot-definition-readers new-slotd) (slot-definition-readers old-slotd)) diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 7903e1dc9..d0bd06aa1 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -355,3 +355,12 @@ values of the last FORM. If no FORM is given, returns NIL." (if (and (consp form) (eq (car form) 'quote)) (second form) form)) + +(defun maybe-quote (form) + ;; Quotes a form only if strictly required. This happens only when FORM is + ;; either a symbol and not a keyword + (if (if (atom form) + (typep form '(and symbol (not keyword) (not boolean))) + (not (eq (first form) 'quote))) + (list 'quote form) + form))