Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Ordering fix

  • Loading branch information...
commit aaef421696b0ad1fa72aaee14a755327c8a65685 1 parent cf70f90
Ryan Pavlik authored

Showing 1 changed file with 20 additions and 16 deletions. Show diff stats Hide diff stats

  1. +20 16 common-methods.lisp
36 common-methods.lisp
@@ -131,20 +131,24 @@
131 131 (values class (nreverse qualifiers) lambda-list options args)))
132 132
133 133 (defun make-method-args (arglist &key (rest-p t))
134   - (let* ((args (mapcar #'(lambda (arg)
135   - (if (and (listp arg)
136   - (keywordp (car arg)))
137   - (if (cddr arg) (cdr arg) (cadr arg))
138   - arg))
139   - arglist))
140   - (rest-decl-pos (position '&rest arglist))
  134 + (let* ((rest-decl-pos (position '&rest arglist))
141 135 (rest-sym (if (not rest-decl-pos)
142   - (gensym "NO-REST-"))))
  136 + (gensym "NO-REST-")))
  137 + (args
  138 + (mapcar #'(lambda (arg)
  139 + (if (and (listp arg)
  140 + (keywordp (car arg)))
  141 + (if (cddr arg) (cdr arg) (cadr arg))
  142 + arg))
  143 + (sort (subseq arglist 0 rest-decl-pos)
  144 + (lambda (a b)
  145 + (string< (if (listp a) (car a) a)
  146 + (if (listp b) (car b) b)))))))
143 147 (values
144 148 (if rest-p
145 149 (if rest-sym
146 150 (append args (list '&rest rest-sym))
147   - args)
  151 + (append args (subseq arglist rest-decl-pos)))
148 152 args)
149 153 rest-sym)))
150 154
@@ -222,8 +226,14 @@
222 226 `(progn
223 227 ,(when self
224 228 `(eval-when (:compile-toplevel :load-toplevel :execute)
225   - ,(unless (fboundp spec-method)
  229 + ,(unless (fboundp `(setf ,spec-method))
226 230 (%define-common-generic `(setf ,spec-method) (append (list value-arg self) spec-args)))
  231 + (defsetf ,method (object &rest method-args) (v)
  232 + (let ((spec-method (method-encode ',method (extract-names method-args))))
  233 + (multiple-value-bind (spec-args rest-args) (make-args method-args)
  234 + (etypecase rest-args
  235 + (list `(setf (,spec-method ,object ,@spec-args ,@rest-args) ,v))
  236 + (null `(setf (,spec-method ,object ,@spec-args) ,v))))))
227 237 (defmethod (setf ,spec-method) ,@qualifiers (,value-arg ,self-arg ,@spec-args)
228 238 ,@(if rest-arg
229 239 (list `(declare (ignore ,rest-arg))))
@@ -231,12 +241,6 @@
231 241 ,(if (or export-p dotted-p)
232 242 `(export ',spec-method (symbol-package ',spec-method))
233 243 `(unexport ',spec-method (symbol-package ',spec-method)))))
234   - (defsetf ,method (object &rest method-args) (v)
235   - (let ((spec-method (method-encode ',method (extract-names method-args))))
236   - (multiple-value-bind (spec-args rest-args) (make-args method-args)
237   - (etypecase rest-args
238   - (list `(setf (,spec-method ,object ,@spec-args ,@rest-args) ,v))
239   - (null `(setf (,spec-method ,object ,@spec-args) ,v))))))
240 244 ,(if dotted-p
241 245 `(progn
242 246 (make-common-method ,(intern (string method) 'cm-dot-methods) t)

0 comments on commit aaef421

Please sign in to comment.
Something went wrong with that request. Please try again.