X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=da7fc9ba21a97e6cf82d9e784a33f9e27844812b;hb=cd99f20d910298cbf5c2000e3dc3595fb0c8418b;hp=e3d348845af3d8c3a04b3adecd126b04d1a832c9;hpb=6f7128b46e9ca91de777f61e8623bf5d997b2987;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index e3d3488..da7fc9b 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -165,7 +165,7 @@ bootstrapping. (qualifiers (subseq qab 0 arglist-pos)) (body (nthcdr (1+ arglist-pos) qab))) `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body) - (generic-function-initial-methods #',fun-name))))) + (generic-function-initial-methods (fdefinition ',fun-name)))))) (macrolet ((initarg (key) `(getf initargs ,key))) (dolist (option options) (let ((car-option (car option))) @@ -239,7 +239,7 @@ bootstrapping. (compile-or-load-defgeneric ',fun-name)) (load-defgeneric ',fun-name ',lambda-list ,@initargs) ,@(mapcar #'expand-method-definition methods) - #',fun-name)))) + (fdefinition ',fun-name))))) (defun compile-or-load-defgeneric (fun-name) (proclaim-as-fun-name fun-name) @@ -263,18 +263,18 @@ bootstrapping. :definition-source `((defgeneric ,fun-name) ,*load-pathname*) initargs)) -;;; As per section 3.4.2 of the ANSI spec, generic function lambda -;;; lists have some special limitations, which we check here. +(define-condition generic-function-lambda-list-error + (reference-condition simple-program-error) + () + (:default-initargs :references (list '(:ansi-cl :section (3 4 2))))) + (defun check-gf-lambda-list (lambda-list) (flet ((ensure (arg ok) (unless ok - (error - ;; (s/invalid/non-ANSI-conforming/ because the old PCL - ;; implementation allowed this, so people got used to - ;; it, and maybe this phrasing will help them to guess - ;; why their program which worked under PCL no longer works.) - "~@" - arg lambda-list)))) + (error 'generic-function-lambda-list-error + :format-control + "~@" + :format-arguments (list arg lambda-list))))) (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) (parse-lambda-list lambda-list) @@ -437,14 +437,14 @@ bootstrapping. (mname `(,(if (eq (cadr initargs-form) :function) 'method 'fast-method) ,name ,@qualifiers ,specls)) - (mname-sym (intern (let ((*print-pretty* nil) - ;; (We bind *PACKAGE* to - ;; KEYWORD here as a way to - ;; force symbols to be printed - ;; with explicit package - ;; prefixes.) - (*package* *keyword-package*)) - (format nil "~S" mname))))) + (mname-sym (let ((*print-pretty* nil) + ;; (We bind *PACKAGE* to KEYWORD here + ;; as a way to force symbols to be + ;; printed with explicit package + ;; prefixes.) + (target *package*) + (*package* *keyword-package*)) + (format-symbol target "~S" mname)))) `(progn (defun ,mname-sym ,(cadr fn-lambda) ,@(cddr fn-lambda)) @@ -460,7 +460,7 @@ bootstrapping. `(list ,@(mapcar (lambda (specializer) (if (consp specializer) ``(,',(car specializer) - ,,(cadr specializer)) + ,,(cadr specializer)) `',specializer)) specializers)) unspecialized-lambda-list @@ -607,6 +607,17 @@ bootstrapping. ;; second argument.) Hopefully it only does this kind of ;; weirdness when bootstrapping.. -- WHN 20000610 '(ignorable)) + ((var-globally-special-p parameter) + ;; KLUDGE: Don't declare types for global special variables + ;; -- our rebinding magic for SETQ cases don't work right + ;; there. + ;; + ;; FIXME: It would be better to detect the SETQ earlier and + ;; skip declarations for specials only when needed, not + ;; always. + ;; + ;; --NS 2004-10-14 + '(ignorable)) (t ;; Otherwise, we can usually make Python very happy. (let ((type (info :type :kind specializer))) @@ -1252,6 +1263,14 @@ bootstrapping. (setq next-method-p-p t) form) ((eq (car form) 'setq) + ;; FIXME: this is possibly a little strong as + ;; conditions go. Ideally we would want to detect + ;; which, if any, of the method parameters are + ;; being set, and communicate that information to + ;; e.g. SPLIT-DECLARATIONS. However, the brute + ;; force method doesn't really cost much; a little + ;; loss of discrimination over IGNORED variables + ;; should be all. -- CSR, 2004-07-01 (setq setq-p t) form) ((and (eq (car form) 'function) @@ -1428,10 +1447,10 @@ bootstrapping. ;; failing that, to use a special ;; symbol prefix denoting privateness. ;; -- WHN 19991201 - (intern (format nil "FAST-~A" - (car method-spec)) - *pcl-package*))) - ,@(cdr method-spec)))) + (format-symbol *pcl-package* + "FAST-~A" + (car method-spec)))) + ,@(cdr method-spec)))) (set-fun-name mff name) (unless mf (set-mf-property :name name))))) @@ -1636,6 +1655,12 @@ bootstrapping. (unless (equal ,pos ,valsym) (setf ,pos ,valsym))))) +(defun create-gf-lambda-list (lambda-list) + ;;; Create a gf lambda list from a method lambda list + (loop for x in lambda-list + collect (if (consp x) (list (car x)) x) + if (eq x '&key) do (loop-finish))) + (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) argument-precedence-order) (let* ((arg-info (if (eq *boot-state* 'complete) @@ -1663,8 +1688,10 @@ bootstrapping. (error "The lambda-list ~S is incompatible with ~ existing methods of ~S." lambda-list gf)))) - (when lambda-list-p - (esetf (arg-info-lambda-list arg-info) lambda-list)) + (esetf (arg-info-lambda-list arg-info) + (if lambda-list-p + lambda-list + (create-gf-lambda-list lambda-list))) (when (or lambda-list-p argument-precedence-order (null (arg-info-precedence arg-info))) (esetf (arg-info-precedence arg-info) @@ -1912,11 +1939,8 @@ bootstrapping. (let* ((method (car (last methods))) (ll (if (consp method) (early-method-lambda-list method) - (method-lambda-list method))) - (k (member '&key ll))) - (if k - (ldiff ll (cdr k)) - ll)))) + (method-lambda-list method)))) + (create-gf-lambda-list ll)))) (arg-info-lambda-list arg-info)))) (defmacro real-ensure-gf-internal (gf-class all-keys env) @@ -1939,7 +1963,7 @@ bootstrapping. (let ((method-class (getf ,all-keys :method-class '.shes-not-there.))) (unless (eq method-class '.shes-not-there.) (setf (getf ,all-keys :method-class) - (find-class method-class t ,env)))))) + (find-class method-class t ,env)))))) (defun real-ensure-gf-using-class--generic-function (existing @@ -2334,6 +2358,11 @@ bootstrapping. (declare (ignore ignore1 ignore2 ignore3)) required-parameters)) +(define-condition specialized-lambda-list-error + (reference-condition simple-program-error) + () + (:default-initargs :references (list '(:ansi-cl :section (3 4 3))))) + (defun parse-specialized-lambda-list (arglist &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux)) @@ -2344,22 +2373,21 @@ bootstrapping. ((eq arg '&aux) (values nil arglist nil nil)) ((memq arg lambda-list-keywords) - ;; Now, since we try to conform to ANSI, non-standard - ;; lambda-list-keywords should be treated as errors. + ;; non-standard lambda-list-keywords are errors. (unless (memq arg specialized-lambda-list-keywords) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "unknown specialized-lambda-list ~ keyword ~S~%" :format-arguments (list arg))) ;; no multiple &rest x &rest bla specifying (when (memq arg supplied-keywords) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "multiple occurrence of ~ specialized-lambda-list keyword ~S~%" :format-arguments (list arg))) ;; And no placing &key in front of &optional, either. (unless (memq arg allowed-keywords) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "misplaced specialized-lambda-list ~ keyword ~S~%" :format-arguments (list arg))) @@ -2382,7 +2410,7 @@ bootstrapping. (not (or (null (cadr lambda-list)) (memq (cadr lambda-list) specialized-lambda-list-keywords))))) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "in a specialized-lambda-list, excactly one ~ variable must follow &REST.~%"