(defun expand-make-instance-form (form)
(let ((class (cadr form)) (initargs (cddr form))
- (keys nil)(allow-other-keys-p nil) key value)
+ (keys nil) (allow-other-keys-p nil) key value)
(when (and (constant-symbol-p class)
(let ((initargs-tail initargs))
(loop (when (null initargs-tail) (return t))
(return nil))
(setq key (eval (pop initargs-tail)))
(setq value (pop initargs-tail))
- (when (eq ':allow-other-keys key)
+ (when (eq :allow-other-keys key)
(setq allow-other-keys-p value))
(push key keys))))
(let* ((class (eval class))
;; 1. Don't worry, I know what I'm doing.
;; 2. You and what army?
;; 3. If you were as smart as you think you are, you
- ;; wouldn't be a copy.
+ ;; wouldn't be a cop.
;; This is case #1.:-) Even if SYM hasn't been defined yet,
;; it must be an implementation function, or we we wouldn't
;; have expanded into it. So declare SYM as defined, so that
(walk-form form env
(lambda (subform context env)
(declare (ignore env))
- (or (and (eq context ':eval)
+ (or (and (eq context :eval)
(consp subform)
(eq (car subform) 'make-instance)
(expand-make-instance-form subform))
(*print-case* :upcase)
(*print-pretty* nil))
(intern (format nil
- "MAKE-INSTANCE ~S ~S ~S"
- class-name
+ "MAKE-INSTANCE ~A::~A ~S ~S"
+ (package-name (symbol-package class-name))
+ (symbol-name class-name)
keys
allow-other-keys-p))))))))
(cached-name (intern (format nil "~A-CACHED-~A" type name))))
`(defmacro ,reader-name (info)
`(let ((value (,',cached-name ,info)))
- (if (eq value ':unknown)
+ (if (eq value :unknown)
(progn
(,',trap ,info ',',name)
(,',cached-name ,info))
initargs-form-list
new-keys
default-initargs-function
- shared-initialize-t-function
- shared-initialize-nil-function
+ shared-initialize-t-fun
+ shared-initialize-nil-fun
constants
combined-initialize-function ; allocate-instance + shared-initialize
make-instance-function ; nil means use gf
(defmacro reset-initialize-info-internal (info)
`(progn
,@(mapcar (lambda (cname)
- `(setf (,cname ,info) ':unknown))
+ `(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))
+ `(unless (eq :unknown (,cached-name info))
(push ',name slots)))
*initialize-info-cached-slots* cached-names)
slots))
((default-initargs-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info)))
(setf (initialize-info-cached-default-initargs-function info)
- (initialize-instance-simple-function
+ (initialize-instance-simple-fun
'default-initargs-function info
class initargs-form-list))))
((valid-p ri-valid-p)
(compute-valid-p
(list (list* 'reinitialize-instance proto nil)
(list* 'shared-initialize proto nil nil)))))))
- ((shared-initialize-t-function)
+ ((shared-initialize-t-fun)
(multiple-value-bind (initialize-form-list ignore)
(make-shared-initialize-form-list class keys t nil)
(declare (ignore ignore))
- (setf (initialize-info-cached-shared-initialize-t-function info)
- (initialize-instance-simple-function
- 'shared-initialize-t-function info
+ (setf (initialize-info-cached-shared-initialize-t-fun info)
+ (initialize-instance-simple-fun
+ 'shared-initialize-t-fun info
class initialize-form-list))))
- ((shared-initialize-nil-function)
+ ((shared-initialize-nil-fun)
(multiple-value-bind (initialize-form-list ignore)
(make-shared-initialize-form-list class keys nil nil)
(declare (ignore ignore))
- (setf (initialize-info-cached-shared-initialize-nil-function info)
- (initialize-instance-simple-function
- 'shared-initialize-nil-function info
+ (setf (initialize-info-cached-shared-initialize-nil-fun info)
+ (initialize-instance-simple-fun
+ 'shared-initialize-nil-fun info
class initialize-form-list))))
((constants combined-initialize-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info))
(make-shared-initialize-form-list class new-keys t t)
(setf (initialize-info-cached-constants info) constants)
(setf (initialize-info-cached-combined-initialize-function info)
- (initialize-instance-simple-function
+ (initialize-instance-simple-fun
'combined-initialize-function info
class (append initargs-form-list initialize-form-list))))))
((make-instance-function-symbol)
(eq (car (method-specializers meth))
*the-class-slot-object*)
(and (null (cdr quals))
- (or (eq (car quals) ':before)
- (eq (car quals) ':after)))))))
+ (or (eq (car quals) :before)
+ (eq (car quals) :after)))))))
(and (every #'check-meth initialize-instance-methods)
(every #'check-meth shared-initialize-methods))))
(return-from get-make-instance-function nil))
(defun complicated-instance-creation-method (m)
(let ((qual (method-qualifiers m)))
(if qual
- (not (and (null (cdr qual)) (eq (car qual) ':after)))
+ (not (and (null (cdr qual)) (eq (car qual) :after)))
(let ((specl (car (method-specializers m))))
(or (not (classp specl))
(not (eq 'slot-object (class-name specl))))))))
initialize-instance-methods)))))
(lambda (class1 initargs)
(if (not (eq wrapper (class-wrapper class)))
- (let* ((info (initialize-info class1 initargs))
+ (let* ((info (initialize-info (coerce-to-class class1) initargs))
(fn (initialize-info-make-instance-function info)))
(declare (type function fn))
(funcall fn class1 initargs))
(list wrapper *the-wrapper-of-t*))))
(lambda (class1 initargs)
(if (not (eq wrapper (class-wrapper class)))
- (let* ((info (initialize-info class1 initargs))
+ (let* ((info (initialize-info (coerce-to-class class1) initargs))
(fn (initialize-info-make-instance-function info)))
(declare (type function fn))
(funcall fn class1 initargs))
info)))
(if separate-p
(values default-initargs-function
- (initialize-info-shared-initialize-t-function info))
+ (initialize-info-shared-initialize-t-fun info))
(values default-initargs-function
- (initialize-info-shared-initialize-t-function
+ (initialize-info-shared-initialize-t-fun
(initialize-info class (initialize-info-new-keys info)
nil allow-other-keys-arg))))))
(wrapper (class-wrapper class))
(constants (when simple-p
(make-list (wrapper-no-of-instance-slots wrapper)
- ':initial-element +slot-unbound+)))
+ :initial-element +slot-unbound+)))
(slots (class-slots class))
(slot-names (mapcar #'slot-definition-name slots))
(slots-key (mapcar (lambda (slot)
(defvar *initialize-instance-simple-alist* nil)
(defvar *note-iis-entry-p* nil)
-(defvar *compiled-initialize-instance-simple-functions*
+(defvar *compiled-initialize-instance-simple-funs*
(make-hash-table :test 'equal))
-(defun initialize-instance-simple-function (use info class form-list)
+(defun initialize-instance-simple-fun (use info class form-list)
(let* ((pv-cell (get-pv-cell-for-class class))
(key (initialize-info-key info))
(sf-key (list* use (class-name (car key)) (cdr key))))
(if (or *compile-make-instance-functions-p*
- (gethash sf-key *compiled-initialize-instance-simple-functions*))
+ (gethash sf-key *compiled-initialize-instance-simple-funs*))
(multiple-value-bind (form args)
(form-list-to-lisp pv-cell form-list)
(let ((entry (assoc form *initialize-instance-simple-alist*
:test #'equal)))
(setf (gethash sf-key
- *compiled-initialize-instance-simple-functions*)
+ *compiled-initialize-instance-simple-funs*)
t)
(if entry
(setf (cdddr entry) (union (list sf-key) (cdddr entry)
(setf (cadr entry) function)
(setf (caddr entry) system)
(dolist (use uses)
- (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
+ (setf (gethash use *compiled-initialize-instance-simple-funs*) t))
(setf (cdddr entry) (union uses (cdddr entry)
:test #'equal))))
`((instance-write-internal pv slots ,(const pv-offset) value
,default
,(typecase location
- (fixnum ':instance)
- (cons ':class)
- (t ':default)))))))
+ (fixnum :instance)
+ (cons :class)
+ (t :default)))))))
(skip-when-instance-boundp
(let* ((pv-offset (cadr form))
(location (pvref pv pv-offset))
pv slots ,(const pv-offset)
,default
,(typecase (pvref pv pv-offset)
- (fixnum ':instance)
- (cons ':class)
- (t ':default))))
+ (fixnum :instance)
+ (cons :class)
+ (t :default))))
,@(let ((sforms (cons nil nil)))
(dotimes-fixnum (i (cadddr form) (car sforms))
(add-forms (first-form-to-lisp forms cvector pv)
projects / sbcl.git / blobdiff