Changeset 14052
- Timestamp:
- 08/04/12 12:56:29 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r14046 r14052 1201 1201 ,emf-form)) 1202 1202 1203 (defmacro with-args-lambda-list (args-lambda-list1204 generic-function-symbol1205 gf-args-symbol1206 &body forms)1207 (let ((gf-lambda-list (gensym))1208 (nrequired (gensym))1209 (noptional (gensym))1210 (rest-args (gensym)))1211 (multiple-value-bind (whole required optional rest keys aux)1212 (parse-define-method-combination-args-lambda-list args-lambda-list)1213 `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list))1214 (,nrequired (length (extract-required-part ,gf-lambda-list)))1215 (,noptional (length (extract-optional-part ,gf-lambda-list)))1216 (,rest-args (subseq ,gf-args-symbol (+ ,nrequired ,noptional)))1217 ,@(when whole `((,whole ,gf-args-symbol)))1218 ,@(loop for var in required and i upfrom 01219 collect `(,var (when (< ,i ,nrequired)1220 (nth ,i ,gf-args-symbol))))1221 ,@(loop for (var init-form) in optional and i upfrom 01222 collect1223 `(,var (if (< ,i ,noptional)1224 (nth (+ ,nrequired ,i) ,gf-args-symbol)1225 ,init-form)))1226 ,@(when rest `((,rest ,rest-args)))1227 ,@(loop for ((key var) init-form) in keys and i upfrom 01228 collect `(,var (getk ,rest-args ',key ,init-form)))1229 ,@(loop for (var init-form) in aux and i upfrom 01230 collect `(,var ,init-form)))1231 ,@forms))))1232 1233 1203 (defun assert-unambiguous-method-sorting (group-name methods) 1234 1204 (let ((specializers (make-hash-table :test 'equal))) … … 1285 1255 (declare (ignore name)) 1286 1256 (let ((methods (gensym)) 1287 (args-var (gensym))) 1257 (args-var (gensym)) 1258 (gf-lambda-list (gensym)) 1259 (emf-form (gensym))) 1288 1260 `(lambda (,generic-function-symbol ,methods ,@lambda-list) 1261 ;; This is the lambda which computes the effective method 1289 1262 ,@declarations 1290 1263 (with-method-groups ,method-group-specs 1291 1264 ,methods 1292 1265 ,(if (null args-lambda-list) 1293 `(let (( emf-form (progn ,@forms)))1266 `(let ((,emf-form (progn ,@forms))) 1294 1267 `(lambda (,',args-var) 1268 ;; This is the lambda which *is* the effective method 1269 ;; hence gets called on every method invocation 1270 ;; be as efficient in this method as we can be 1295 1271 ,(wrap-with-call-method-macro ,generic-function-symbol 1296 ',args-var emf-form))) 1297 `(lambda (,args-var) 1298 (let* ((emf-form 1299 (with-args-lambda-list ,args-lambda-list 1300 ,generic-function-symbol ,args-var 1301 ,@forms)) 1302 (function 1303 `(lambda (,',args-var) ;; ugly: we're reusing it 1304 ;; to prevent calling gensym on every EMF invocation 1305 ,(wrap-with-call-method-macro ,generic-function-symbol 1306 ',args-var emf-form)))) 1307 (funcall function ,args-var)))))))) 1272 ',args-var ,emf-form))) 1273 (multiple-value-bind 1274 (whole required optional rest keys aux) 1275 (parse-define-method-combination-args-lambda-list args-lambda-list) 1276 `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 1277 'sys::lambda-list)) 1278 (nreq (length (extract-required-part ,gf-lambda-list))) 1279 (nopt (length (extract-optional-part ,gf-lambda-list))) 1280 (,emf-form 1281 (let* (,@(when whole 1282 `((,whole ',args-var))) 1283 ,@(when rest 1284 `((,rest `(subseq ,',args-var 1285 (+ ,nreq ,nopt))))) 1286 ,@(loop for var in required 1287 and i upfrom 0 1288 collect `(,var (when (< ,i nreq) 1289 `(nth ,,i ,',args-var)))) 1290 ,@(loop for (var initform) in optional 1291 and i upfrom 0 1292 ;; check for excess parameters 1293 ;; only assign initform if the parameter 1294 ;; isn't in excess: the spec says explicitly 1295 ;; to bind those in excess to forms evaluating 1296 ;; to nil. 1297 ;; This leaves initforms to be used with 1298 ;; parameters not supplied in excess, but 1299 ;; not available arguments list 1300 ;; 1301 ;; Also, if specified, bind "supplied-p" 1302 collect `(,var (if (< ,i nopt) 1303 `(nth ,(+ ,i nreq) 1304 ,',args-var) 1305 ',initform))) 1306 ,@(loop for ((key var) initform) in keys 1307 ;; Same as optional parameters: 1308 ;; even though keywords can't be supplied in 1309 ;; excess, we should bind "supplied-p" in case 1310 ;; the key isn't supplied in the arguments list 1311 collect `(,var `(getk (subseq ,',args-var 1312 (+ ,nreq ,nopt)) ,',key 1313 ,',initform))) 1314 ,@(loop for (var initform) in aux 1315 collect `(,var ',initform))) 1316 ,@forms))) 1317 `(lambda (,',args-var) 1318 ;; This is the lambda which *is* the effective method 1319 ;; hence gets called on every method invocation 1320 ;; be as efficient in this method as we can be 1321 ,(wrap-with-call-method-macro ,generic-function-symbol 1322 ',args-var ,emf-form))))))))) 1308 1323 1309 1324 (defun declarationp (expr)
Note: See TracChangeset
for help on using the changeset viewer.