mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-09 06:30:32 -07:00
Code Issues Projects Releases Packages Wiki Activity

ECL now follows the AMOP in the uses of SLOT-DEFINITION-INITFORM and SLOT-DEFINITION-INITFUNCTION.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2008-12-29 11:33:28 +01:00
parent c22c15726a
commit 786affb7c5
7 changed files with 72 additions and 54 deletions
Download patch file Download diff file Expand all files Collapse all files

10
src/CHANGELOG
View file

@ -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 ***

6
src/c/symbols_list.h
View file

@ -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}};

6
src/c/symbols_list2.h
View file

@ -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}};

51
src/clos/defclass.lsp
View file

@ -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

27
src/clos/slot.lsp
View file

@ -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))

17
src/clos/standard.lsp
View file

@ -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))

9
src/lsp/evalmacros.lsp
View file

@ -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))