(unless (listp wrappers) (setq wrappers (list wrappers)))
(let* ((not-simple-p-cell (list nil))
(elements
- (gathering1 (collecting)
- (iterate ((slot-names (list-elements slot-name-lists)))
+ (let ((elements nil))
+ (dolist (slot-names slot-name-lists)
(when slot-names
(let* ((wrapper (pop wrappers))
(std-p (typep wrapper 'wrapper))
(class (wrapper-class* wrapper))
(class-slots (and std-p (wrapper-class-slots wrapper))))
(dolist (slot-name (cdr slot-names))
- (gather1
- (when std-p
- (compute-pv-slot slot-name wrapper class
- class-slots not-simple-p-cell))))))))))
+ ;; Original PCL code had this idiom. why not:
+ ;;
+ ;; (WHEN STD-P
+ ;; (PUSH ...)) ?
+ (push (when std-p
+ (compute-pv-slot slot-name wrapper class
+ class-slots not-simple-p-cell))
+ elements)))))
+ (nreverse elements))))
(if (car not-simple-p-cell)
(make-permutation-vector (cons t elements))
(or (gethash elements *pvs*)
(declare (ignore call-list wrappers))
#||
(map 'vector
- #'(lambda (call)
- (compute-emf-from-wrappers call wrappers))
+ (lambda (call)
+ (compute-emf-from-wrappers call wrappers))
call-list)
||#
'#())
(destructuring-bind (gf-name nreq restp arg-info) call
(if (eq gf-name 'make-instance)
(error "should not get here") ; there is another mechanism for this.
- #'(lambda (&rest args)
- (if (not (eq *boot-state* 'complete))
- (apply (gdefinition gf-name) args)
- (let* ((gf (gdefinition gf-name))
- (arg-info (arg-info-reader gf))
- (classes '?)
- (types '?)
- (emf (cache-miss-values-internal gf arg-info
- wrappers classes types
- 'caching)))
- (update-all-pv-tables call wrappers emf)
- (invoke-emf emf args))))))))
+ (lambda (&rest args)
+ (if (not (eq *boot-state* 'complete))
+ (apply (gdefinition gf-name) args)
+ (let* ((gf (gdefinition gf-name))
+ (arg-info (arg-info-reader gf))
+ (classes '?)
+ (types '?)
+ (emf (cache-miss-values-internal gf arg-info
+ wrappers classes types
+ 'caching)))
+ (update-all-pv-tables call wrappers emf)
+ (invoke-emf emf args))))))))
||#
(defun make-permutation-vector (indexes)
(std-p (typep cwrapper 'wrapper))
(class-slots (and std-p (wrapper-class-slots cwrapper)))
(class-slot-p-cell (list nil))
- (new-values (mapcar #'(lambda (slot-name)
- (cons slot-name
- (when std-p
- (compute-pv-slot
- slot-name cwrapper class
- class-slots class-slot-p-cell))))
+ (new-values (mapcar (lambda (slot-name)
+ (cons slot-name
+ (when std-p
+ (compute-pv-slot
+ slot-name cwrapper class
+ class-slots class-slot-p-cell))))
slot-names))
(pv-tables nil))
(dolist (slot-name slot-names)
(map-pv-table-references-of
slot-name
- #'(lambda (pv-table pv-offset-list)
- (declare (ignore pv-offset-list))
- (pushnew pv-table pv-tables))))
+ (lambda (pv-table pv-offset-list)
+ (declare (ignore pv-offset-list))
+ (pushnew pv-table pv-tables))))
(dolist (pv-table pv-tables)
(let* ((cache (pv-table-cache pv-table))
(slot-name-lists (pv-table-slot-name-lists pv-table))
(incf map-index))
(incf param-index)))
(when cache
- (map-cache #'(lambda (wrappers pv-cell)
- (setf (car pv-cell)
- (update-slots-in-pv wrappers (car pv-cell)
- cwrapper pv-size pv-map)))
+ (map-cache (lambda (wrappers pv-cell)
+ (setf (car pv-cell)
+ (update-slots-in-pv wrappers (car pv-cell)
+ cwrapper pv-size pv-map)))
cache))))))
(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
;; against 'THE scattered through the PCL code.
(setq var (caddr var)))
(when (symbolp var)
- (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
- var
- env)))
+ (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
(parameter-or-nil (car (memq (or rebound? var)
required-parameters))))
(when parameter-or-nil
- (let* ((class-name (caddr (variable-declaration '%class
- parameter-or-nil
- env)))
+ (let* ((class-name (caddr (var-declaration '%class
+ parameter-or-nil
+ env)))
(class (find-class class-name nil)))
(when (or (not (eq *boot-state* 'complete))
(and class (not (class-finalized-p class))))
(eq (car form) 'the))
(setq form (caddr form)))
(or (and (symbolp form)
- (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
- form env)))
+ (let* ((rebound? (caddr (var-declaration '%variable-rebinding
+ form
+ env)))
(parameter-or-nil (car (assq (or rebound? form) slots))))
(when parameter-or-nil
- (let* ((class-name (caddr (variable-declaration
- 'class parameter-or-nil env))))
+ (let* ((class-name (caddr (var-declaration 'class
+ parameter-or-nil
+ env))))
(when (and class-name (not (eq class-name t)))
(position parameter-or-nil slots :key #'car))))))
(if (constantp form)
(non-required-args (nthcdr nreq args))
(required-args (ldiff args non-required-args))
(call-spec (list (car gf-call-form) nreq restp
- (mapcar #'(lambda (form)
- (optimize-gf-call-internal form slots env))
+ (mapcar (lambda (form)
+ (optimize-gf-call-internal form slots env))
(if all-args-p
args
required-args))))
(defmacro instance-read-internal (pv slots pv-offset default &optional type)
(unless (member type '(nil :instance :class :default))
(error "illegal type argument to ~S: ~S" 'instance-read-internal type))
- (if (eq type ':default)
+ (if (eq type :default)
default
(let* ((index (gensym))
(value index))
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,pv ,pv-offset)))
(setq ,value (typecase ,index
- ,@(when (or (null type) (eq type ':instance))
+ ,@(when (or (null type) (eq type :instance))
`((fixnum (clos-slots-ref ,slots ,index))))
- ,@(when (or (null type) (eq type ':class))
+ ,@(when (or (null type) (eq type :class))
`((cons (cdr ,index))))
(t +slot-unbound+)))
(if (eq ,value +slot-unbound+)
`(instance-read-internal .pv. ,(slot-vector-symbol position)
,pv-offset (accessor-slot-value ,parameter ,slot-name)
,(if (generate-fast-class-slot-access-p class slot-name)
- ':class ':instance))))
+ :class :instance))))
(defmacro instance-reader (pv-offset parameter position gf-name class)
(declare (ignore class))
&optional type)
(unless (member type '(nil :instance :class :default))
(error "illegal type argument to ~S: ~S" 'instance-write-internal type))
- (if (eq type ':default)
+ (if (eq type :default)
default
(let* ((index (gensym)))
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
- ,@(when (or (null type) (eq type ':instance))
+ ,@(when (or (null type) (eq type :instance))
`((fixnum (setf (clos-slots-ref ,slots ,index)
,new-value))))
- ,@(when (or (null type) (eq type ':class))
+ ,@(when (or (null type) (eq type :class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
,pv-offset ,new-value
(accessor-set-slot-value ,parameter ,slot-name ,new-value)
,(if (generate-fast-class-slot-access-p class slot-name)
- ':class ':instance))))
+ :class :instance))))
(defmacro instance-writer (pv-offset
parameter
&optional type)
(unless (member type '(nil :instance :class :default))
(error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
- (if (eq type ':default)
+ (if (eq type :default)
default
(let* ((index (gensym)))
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
- ,@(when (or (null type) (eq type ':instance))
+ ,@(when (or (null type) (eq type :instance))
`((fixnum (not (and ,slots
(eq (clos-slots-ref ,slots ,index)
+slot-unbound+))))))
- ,@(when (or (null type) (eq type ':class))
+ ,@(when (or (null type) (eq type :class))
`((cons (not (eq (cdr ,index) +slot-unbound+)))))
(t ,default)))))))
`(instance-boundp-internal .pv. ,(slot-vector-symbol position)
,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
,(if (generate-fast-class-slot-access-p class slot-name)
- ':class ':instance))))
+ :class :instance))))
;;; This magic function has quite a job to do indeed.
;;;
(defun slot-name-lists-from-slots (slots calls)
(multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls)
(let* ((slot-name-lists
- (mapcar #'(lambda (parameter-entry)
- (cons nil (mapcar #'car (cdr parameter-entry))))
+ (mapcar (lambda (parameter-entry)
+ (cons nil (mapcar #'car (cdr parameter-entry))))
slots))
(call-list
(mapcar #'car calls)))
(dolist (arg (cdr call))
(when (integerp arg)
(setf (car (nth arg slot-name-lists)) t))))
- (setq slot-name-lists (mapcar #'(lambda (r+snl)
- (when (or (car r+snl) (cdr r+snl))
- r+snl))
+ (setq slot-name-lists (mapcar (lambda (r+snl)
+ (when (or (car r+snl) (cdr r+snl))
+ r+snl))
slot-name-lists))
(let ((cvt (apply #'vector
(let ((i -1))
- (mapcar #'(lambda (r+snl)
- (when r+snl (incf i)))
+ (mapcar (lambda (r+snl)
+ (when r+snl (incf i)))
slot-name-lists)))))
- (setq call-list (mapcar #'(lambda (call)
- (cons (car call)
- (mapcar #'(lambda (arg)
- (if (integerp arg)
- (svref cvt arg)
- arg))
- (cdr call))))
+ (setq call-list (mapcar (lambda (call)
+ (cons (car call)
+ (mapcar (lambda (arg)
+ (if (integerp arg)
+ (svref cvt arg)
+ arg))
+ (cdr call))))
call-list)))
(values slot-name-lists call-list))))
(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
&body body)
- (with-gathering ((slot-vars (collecting))
- (pv-parameters (collecting)))
- (iterate ((slots (list-elements slot-name-lists))
- (required-parameter (list-elements required-parameters))
- (i (interval :from 0)))
- (when slots
- (gather required-parameter pv-parameters)
- (gather (slot-vector-symbol i) slot-vars)))
- `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars)
+ (let (slot-vars pv-parameters)
+ (loop for slots in slot-name-lists
+ for required-parameter in required-parameters
+ for i from 0
+ do (when slots
+ (push required-parameter pv-parameters)
+ (push (slot-vector-symbol i) slot-vars)))
+ `(pv-binding1 (.pv. .calls. ,pv-table-symbol
+ ,(nreverse pv-parameters) ,(nreverse slot-vars))
,@body)))
(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)
&body body)
`(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
- (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
- slot-vars pv-parameters))
+ (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
+ slot-vars pv-parameters))
,@body)))
-;;; This gets used only when the default MAKE-METHOD-LAMBDA is overridden.
+;;; This gets used only when the default MAKE-METHOD-LAMBDA is
+;;; overridden.
(defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
&rest forms)
`(let* ((.pv-table. ,pv-table-symbol)
,pv ,calls
,@forms))
-(defvar *non-variable-declarations*
+(defvar *non-var-declarations*
;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
;; SBCL doesn't have 'em, VALUES should probably be removed from
'(values %method-name %method-lambda-list
optimize ftype inline notinline))
-(defvar *variable-declarations-with-argument*
+(defvar *var-declarations-with-argument*
'(%class
type))
-(defvar *variable-declarations-without-argument*
+(defvar *var-declarations-without-argument*
'(ignore
ignorable special dynamic-extent
;; FIXME: Possibly this entire list and variable could go away.
(dolist (form (cdr decl))
(when (consp form)
(let ((declaration-name (car form)))
- (if (member declaration-name *non-variable-declarations*)
+ (if (member declaration-name *non-var-declarations*)
(push `(declare ,form) outer-decls)
(let ((arg-p
(member declaration-name
- *variable-declarations-with-argument*))
+ *var-declarations-with-argument*))
(non-arg-p
(member declaration-name
- *variable-declarations-without-argument*))
+ *var-declarations-without-argument*))
(dname (list (pop form)))
(inners nil) (outers nil))
(unless (or arg-p non-arg-p)
;; FIXME: This warning, and perhaps the
- ;; various *VARIABLE-DECLARATIONS-FOO* and/or
- ;; *NON-VARIABLE-DECLARATIONS* variables,
+ ;; various *VAR-DECLARATIONS-FOO* and/or
+ ;; *NON-VAR-DECLARATIONS* variables,
;; could probably go away now that we're not
;; trying to be portable between different
;; CLTL1 hosts the way PCL was. (Note that to
(Assuming it is a variable declaration without argument)."
declaration-name 'split-declarations
declaration-name
- '*non-variable-declarations*
- '*variable-declarations-with-argument*
- '*variable-declarations-without-argument*)
+ '*non-var-declarations*
+ '*var-declarations-with-argument*
+ '*var-declarations-without-argument*)
(push declaration-name
- *variable-declarations-without-argument*))
+ *var-declarations-without-argument*))
(when arg-p
(setq dname (append dname (list (pop form)))))
(dolist (var form)
(when (eq arg '&aux) (return nil))
(incf nreq)(push arg args))
(setq args (nreverse args))
- (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp))
+ (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp))
(make-method-initargs-form-internal1
initargs (cddr lmf) args lmf-params restp)))))
(defun method-function-from-fast-function (fmf)
(declare (type function fmf))
(let* ((method-function nil) (pv-table nil)
- (arg-info (method-function-get fmf ':arg-info))
+ (arg-info (method-function-get fmf :arg-info))
(nreq (car arg-info))
(restp (cdr arg-info)))
(setq method-function
- #'(lambda (method-args next-methods)
- (unless pv-table
- (setq pv-table (method-function-pv-table fmf)))
- (let* ((pv-cell (when pv-table
- (get-method-function-pv-cell
- method-function method-args pv-table)))
- (nm (car next-methods))
- (nms (cdr next-methods))
- (nmc (when nm
- (make-method-call
- :function (if (std-instance-p nm)
- (method-function nm)
- nm)
- :call-method-args (list nms)))))
- (if restp
- (let* ((rest (nthcdr nreq method-args))
- (args (ldiff method-args rest)))
- (apply fmf pv-cell nmc (nconc args (list rest))))
- (apply fmf pv-cell nmc method-args)))))
+ (lambda (method-args next-methods)
+ (unless pv-table
+ (setq pv-table (method-function-pv-table fmf)))
+ (let* ((pv-cell (when pv-table
+ (get-method-function-pv-cell
+ method-function method-args pv-table)))
+ (nm (car next-methods))
+ (nms (cdr next-methods))
+ (nmc (when nm
+ (make-method-call
+ :function (if (std-instance-p nm)
+ (method-function nm)
+ nm)
+ :call-method-args (list nms)))))
+ (if restp
+ (let* ((rest (nthcdr nreq method-args))
+ (args (ldiff method-args rest)))
+ (apply fmf pv-cell nmc (nconc args (list rest))))
+ (apply fmf pv-cell nmc method-args)))))
(let* ((fname (method-function-get fmf :name))
(name `(,(or (get (car fname) 'method-sym)
(setf (get (car fname) 'method-sym)
projects / sbcl.git / blobdiff