(defmacro expanding-make-instance (&rest forms &environment env)
`(progn
- ,@(mapcar #'(lambda (form)
- (walk-form form env
- #'(lambda (subform context env)
- (declare (ignore env))
- (or (and (eq context ':eval)
- (consp subform)
- (eq (car subform) 'make-instance)
- (expand-make-instance-form subform))
- subform))))
+ ,@(mapcar (lambda (form)
+ (walk-form form env
+ (lambda (subform context env)
+ (declare (ignore env))
+ (or (and (eq context ':eval)
+ (consp subform)
+ (eq (car subform) 'make-instance)
+ (expand-make-instance-form subform))
+ subform))))
forms)))
(defun get-make-instance-functions (key-list)
(defmacro define-initialize-info ()
(let ((cached-slot-names
- (mapcar #'(lambda (name)
- (intern (format nil "CACHED-~A" name)))
+ (mapcar (lambda (name)
+ (intern (format nil "CACHED-~A" name)))
*initialize-info-cached-slots*))
(cached-names
- (mapcar #'(lambda (name)
- (intern (format nil "~A-CACHED-~A"
- 'initialize-info name)))
+ (mapcar (lambda (name)
+ (intern (format nil "~A-CACHED-~A"
+ 'initialize-info name)))
*initialize-info-cached-slots*)))
`(progn
(defstruct (initialize-info (:copier nil))
key wrapper
- ,@(mapcar #'(lambda (name)
- `(,name :unknown))
+ ,@(mapcar (lambda (name)
+ `(,name :unknown))
cached-slot-names))
(defmacro reset-initialize-info-internal (info)
`(progn
- ,@(mapcar #'(lambda (cname)
- `(setf (,cname ,info) ':unknown))
+ ,@(mapcar (lambda (cname)
+ `(setf (,cname ,info) ':unknown))
',cached-names)))
(defun initialize-info-bound-slots (info)
(let ((slots nil))
- ,@(mapcar #'(lambda (name cached-name)
- `(unless (eq ':unknown (,cached-name info))
- (push ',name slots)))
+ ,@(mapcar (lambda (name cached-name)
+ `(unless (eq ':unknown (,cached-name info))
+ (push ',name slots)))
*initialize-info-cached-slots* cached-names)
slots))
- ,@(mapcar #'(lambda (name)
- `(define-cached-reader initialize-info ,name
- update-initialize-info-internal))
+ ,@(mapcar (lambda (name)
+ `(define-cached-reader initialize-info ,name
+ update-initialize-info-internal))
*initialize-info-cached-slots*))))
(define-initialize-info)
(setq class (find-class class)))
(when (classp class)
(unless (class-finalized-p class) (finalize-inheritance class)))
- (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
+ (let* ((initargs (mapcan (lambda (key) (list key nil)) keys))
(class-and-initargs (list* class initargs))
(make-instance (gdefinition 'make-instance))
(make-instance-methods
(list* proto t initargs)))))
(when (null make-instance-methods)
(return-from get-make-instance-function
- #'(lambda (class initargs)
- (apply #'no-applicable-method make-instance class initargs))))
+ (lambda (class initargs)
+ (apply #'no-applicable-method make-instance class initargs))))
(unless (and (null (cdr make-instance-methods))
(eq (car make-instance-methods) std-mi-meth)
(null (cdr default-initargs-methods))
(std-si-meth (find-standard-ii-method shared-initialize-methods
'slot-object))
(shared-initfns
- (nreverse (mapcar #'(lambda (method)
- (make-effective-method-function
- #'shared-initialize
- `(call-method ,method nil)
- nil lwrapper))
+ (nreverse (mapcar (lambda (method)
+ (make-effective-method-function
+ #'shared-initialize
+ `(call-method ,method nil)
+ nil lwrapper))
(remove std-si-meth shared-initialize-methods))))
(std-ii-meth (find-standard-ii-method initialize-instance-methods
'slot-object))
(initialize-initfns
- (nreverse (mapcar #'(lambda (method)
- (make-effective-method-function
- #'initialize-instance
- `(call-method ,method nil)
- nil lwrapper))
+ (nreverse (mapcar (lambda (method)
+ (make-effective-method-function
+ #'initialize-instance
+ `(call-method ,method nil)
+ nil lwrapper))
(remove std-ii-meth
initialize-instance-methods)))))
- #'(lambda (class1 initargs)
- (if (not (eq wrapper (class-wrapper class)))
- (let* ((info (initialize-info class1 initargs))
- (fn (initialize-info-make-instance-function info)))
- (declare (type function fn))
- (funcall fn class1 initargs))
- (let* ((instance (funcall allocate-function wrapper constants))
- (initargs (call-initialize-function initialize-function
- instance initargs)))
- (dolist (fn shared-initfns)
- (invoke-effective-method-function fn t instance t initargs))
- (dolist (fn initialize-initfns)
- (invoke-effective-method-function fn t instance initargs))
- instance))))))
+ (lambda (class1 initargs)
+ (if (not (eq wrapper (class-wrapper class)))
+ (let* ((info (initialize-info class1 initargs))
+ (fn (initialize-info-make-instance-function info)))
+ (declare (type function fn))
+ (funcall fn class1 initargs))
+ (let* ((instance (funcall allocate-function wrapper constants))
+ (initargs (call-initialize-function initialize-function
+ instance initargs)))
+ (dolist (fn shared-initfns)
+ (invoke-effective-method-function fn t instance t initargs))
+ (dolist (fn initialize-initfns)
+ (invoke-effective-method-function fn t instance initargs))
+ instance))))))
(defun make-instance-function-complex (key class keys
initialize-instance-methods
`((class-eq ,class) t t)
`((,(find-standard-ii-method shared-initialize-methods
'slot-object)
- ,#'(lambda (instance init-type &rest initargs)
- (declare (ignore init-type))
- (call-initialize-function initialize-function
- instance initargs)
- instance)))
+ ,(lambda (instance init-type &rest initargs)
+ (declare (ignore init-type))
+ (call-initialize-function initialize-function
+ instance initargs)
+ instance)))
(list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
(initialize-instance
(get-secondary-dispatch-function
`((class-eq ,class) t)
`((,(find-standard-ii-method initialize-instance-methods
'slot-object)
- ,#'(lambda (instance &rest initargs)
- (invoke-effective-method-function
- shared-initialize t instance t initargs))))
+ ,(lambda (instance &rest initargs)
+ (invoke-effective-method-function
+ shared-initialize t instance t initargs))))
(list wrapper *the-wrapper-of-t*))))
- #'(lambda (class1 initargs)
- (if (not (eq wrapper (class-wrapper class)))
- (let* ((info (initialize-info class1 initargs))
- (fn (initialize-info-make-instance-function info)))
- (declare (type function fn))
- (funcall fn class1 initargs))
- (let* ((initargs (call-initialize-function initargs-function
- nil initargs))
- (instance (apply #'allocate-instance class initargs)))
- (invoke-effective-method-function
- initialize-instance t instance initargs)
- instance))))))
+ (lambda (class1 initargs)
+ (if (not (eq wrapper (class-wrapper class)))
+ (let* ((info (initialize-info class1 initargs))
+ (fn (initialize-info-make-instance-function info)))
+ (declare (type function fn))
+ (funcall fn class1 initargs))
+ (let* ((initargs (call-initialize-function initargs-function
+ nil initargs))
+ (instance (apply #'allocate-instance class initargs)))
+ (invoke-effective-method-function
+ initialize-instance t instance initargs)
+ instance))))))
(defun get-simple-initialization-function (class
keys
(default-initargs (class-default-initargs class))
(nkeys keys)
(slots-alist
- (mapcan #'(lambda (slot)
- (mapcar #'(lambda (arg)
- (cons arg slot))
- (slot-definition-initargs slot)))
+ (mapcan (lambda (slot)
+ (mapcar (lambda (arg)
+ (cons arg slot))
+ (slot-definition-initargs slot)))
(class-slots class)))
(nslots nil))
(dolist (key nkeys)
':initial-element +slot-unbound+)))
(slots (class-slots class))
(slot-names (mapcar #'slot-definition-name slots))
- (slots-key (mapcar #'(lambda (slot)
- (let ((index most-positive-fixnum))
- (dolist (key (slot-definition-initargs slot))
- (let ((pos (position key keys)))
- (when pos (setq index (min index pos)))))
- (cons slot index)))
+ (slots-key (mapcar (lambda (slot)
+ (let ((index most-positive-fixnum))
+ (dolist (key (slot-definition-initargs slot))
+ (let ((pos (position key keys)))
+ (when pos (setq index (min index pos)))))
+ (cons slot index)))
slots))
(slots (stable-sort slots-key #'< :key #'cdr)))
(let ((n-popped 0))
(apply (the function (cadr entry)) args)
`(call-initialize-instance-simple ,pv-cell ,form-list))))
#||
- #'(lambda (instance initargs)
- (initialize-instance-simple pv-cell form-list instance initargs))
+ (lambda (instance initargs)
+ (initialize-instance-simple pv-cell form-list instance initargs))
||#
`(call-initialize-instance-simple ,pv-cell ,form-list))))
(values
`(lambda (pv-cell cvector)
(declare (type ,cvector-type cvector))
- #'(lambda (instance initargs)
- (declare #.*optimize-speed*)
- (iis-body ,@body)
- initargs))
+ (lambda (instance initargs)
+ (declare #.*optimize-speed*)
+ (iis-body ,@body)
+ initargs))
(list pv-cell (coerce cvector cvector-type)))))
\f
;;; The effect of this is to cause almost all of the overhead of
projects / sbcl.git / blobdiff