From 4aa821e9e539c0a6c0b07329e61fa32da2a0c850 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sun, 4 May 2003 17:50:32 +0000 Subject: [PATCH] Generate inline code for keyword argument processing in methods. Cleanup the code involved. * src/pcl/boot.lisp (keyword-argument-processor): New function. (bind-args): Rewritten. (get-key-arg, get-key-arg1): Removed. --- pcl/boot.lisp | 153 ++++++++++++++++++++++---------------------------- 1 file changed, 67 insertions(+), 86 deletions(-) diff --git a/pcl/boot.lisp b/pcl/boot.lisp index d9ec902ee..f25e2ed62 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.51 2003/05/04 13:11:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.52 2003/05/04 17:50:32 gerd Exp $") (in-package :pcl) @@ -928,74 +928,72 @@ work during bootstrapping. ,@body)))) (defmacro bind-args ((lambda-list args) &body body) - (let ((args-tail '.args-tail.) - (key '.key.) - (state 'required) - (key-seen nil) - (nkeys 0)) - (flet ((process-var (var) - (if (memq var lambda-list-keywords) - (progn - (ecase var - (&optional (setq state 'optional)) - (&key (setq state 'key key-seen t)) - (&allow-other-keys) - (&rest (setq state 'rest)) - (&aux (setq state 'aux))) - nil) - (case state - (required - `((,var (pop ,args-tail)))) - (optional - (cond ((not (consp var)) - `((,var (when ,args-tail (pop ,args-tail))))) - ((null (cddr var)) - `((,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))) - (t - `((,(caddr var) ,args-tail) - (,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))))) - (rest - `((,var ,args-tail))) - (key - (incf nkeys) - (cond ((not (consp var)) - `((,var (get-key-arg ,(make-keyword var) - ,args-tail ',(= 1 nkeys))))) - ((null (cddr var)) - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) (cadar var)) - (values (make-keyword (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail - ',(= 1 nkeys))) - (,variable (if (consp ,key) - (car ,key) - ,(cadr var)))))) - (t - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) (cadar var)) - (values (make-keyword (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail - ',(= 1 nkeys))) - (,(caddr var) ,key) - (,variable (if (consp ,key) - (car ,key) - ,(cadr var)))))))) - (aux - `(,var)))))) - (let ((bindings (mapcan #'process-var lambda-list))) - `(let* ((,args-tail ,args) - ,@bindings - (.dummy. ,@(when (and key-seen (zerop nkeys)) - `((get-key-arg1 :allow-other-keys - ,args-tail t))))) - (declare (ignorable ,args-tail .dummy.)) - ,@body))))) + (let ((state 'required) + (key-seen nil)) + (collect ((keys) (binds)) + (flet ((process-var (var) + (if (memq var lambda-list-keywords) + (progn + (when (eq var '&key) (setq key-seen t)) + (setq state var)) + (ecase state + (&required (binds `(,var (pop .args.)))) + (&optional + (etypecase var + (symbol + (binds `(,var (when .args. (pop .args.))))) + (cons + (destructuring-bind (var &optional def supplied) + var + (when supplied + (binds `(,supplied .args.))) + (binds `(,var (if .args. (pop .args.) ,def))))))) + (&rest (binds `(,var .args.))) + (&key (keys var)) + (&aux (binds var)))))) + (mapc #'process-var lambda-list) + (multiple-value-bind (key-processor key-bindings) + (when key-seen + (keyword-argument-processor (keys))) + (multiple-value-bind (real-body declarations doc) + (system:parse-body body nil nil) + (declare (ignore doc)) + `(let* ((.args. ,args) ,@(binds) ,@key-bindings) + (declare (ignorable .args.)) + ,@declarations + ,@(and key-processor (list key-processor)) + ,@real-body))))))) + +(defun keyword-argument-processor (keys) + (collect ((cases) (binds)) + (flet ((make-case (keyword var &optional value supplied) + (let ((supplied (or supplied (gensym)))) + (cases `(,keyword + (unless ,supplied + (setq ,var (car .more.) ,supplied .more.)))) + (binds `(,var ,value)) + (binds `(,supplied nil))))) + (dolist (key keys) + (etypecase key + (symbol + (make-case (make-keyword key) key)) + (cons + (destructuring-bind (var &optional value supplied) key + (multiple-value-bind (keyword var) + (if (consp var) + (destructuring-bind (keyword var) var + (values keyword var)) + (values (make-keyword var) var)) + (make-case keyword var value supplied)))))) + (values `(loop for (.keyword. . .more.) on .args. by #'cddr do + (cond ((null .more.) + (odd-number-of-keyword-arguments)) + ((not (symbolp .keyword.)) + (invalid-keyword-argument .keyword.)) + (t + (case .keyword. + ,@(cases))))) + (binds))))) (defun odd-number-of-keyword-arguments () (simple-program-error "Odd number of keyword arguments.")) @@ -1003,23 +1001,6 @@ work during bootstrapping. (defun invalid-keyword-argument (key) (simple-program-error "Invalid keyword argument ~s" key)) -(defun get-key-arg (keyword list first-time) - (car (get-key-arg1 keyword list first-time))) - -(defun get-key-arg1 (keyword list first-time) - (if first-time - (loop with cell = nil - for (key . more) on list by #'cddr do - (cond ((not (symbolp key)) - (invalid-keyword-argument key)) - ((null more) - (odd-number-of-keyword-arguments)) - ((and (null cell) (eq key keyword)) - (setq cell more))) - finally (return cell)) - (loop for (key . more) on list by #'cddr - when (eq key keyword) return more))) - (defun walk-method-lambda (method-lambda required-parameters env slots calls) (let ((call-next-method-p nil) ;flag indicating that call-next-method ;should be in the method definition -- GitLab