From: Christophe Rhodes Date: Fri, 31 Dec 2004 15:53:50 +0000 (+0000) Subject: 0.8.18.8: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cce46771e6d734c275f3e2d5620004da3b5d09ee;p=sbcl.git 0.8.18.8: Make METHOD and FAST-METHOD generalized function names ... some adjustments in NAMED-LAMBDAs; ... no more INTERN-FUN-NAME, yay. --- diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index da7fc9b..083dfc4 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -436,23 +436,15 @@ bootstrapping. specializers)) (mname `(,(if (eq (cadr initargs-form) :function) 'method 'fast-method) - ,name ,@qualifiers ,specls)) - (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)))) + ,name ,@qualifiers ,specls))) `(progn - (defun ,mname-sym ,(cadr fn-lambda) + (defun ,mname ,(cadr fn-lambda) ,@(cddr fn-lambda)) ,(make-defmethod-form-internal name qualifiers `',specls unspecialized-lambda-list method-class-name `(list* ,(cadr initargs-form) - #',mname-sym + #',mname ,@(cdddr initargs-form)) pv-table-symbol))) (make-defmethod-form-internal @@ -1437,20 +1429,7 @@ bootstrapping. (when mf (setq mf (set-fun-name mf method-spec))) (when mff - (let ((name `(,(or (get (car method-spec) 'fast-sym) - (setf (get (car method-spec) 'fast-sym) - ;; KLUDGE: If we're going to be - ;; interning private symbols in our - ;; a this way, it would be cleanest - ;; to use a separate package - ;; %PCL-PRIVATE or something, and - ;; failing that, to use a special - ;; symbol prefix denoting privateness. - ;; -- WHN 19991201 - (format-symbol *pcl-package* - "FAST-~A" - (car method-spec)))) - ,@(cdr method-spec)))) + (let ((name `(fast-method ,@(cdr method-spec)))) (set-fun-name mff name) (unless mf (set-mf-property :name name))))) @@ -2311,11 +2290,10 @@ bootstrapping. gf (method-generic-function method) temp (and gf (generic-function-name gf)) name (if temp - (intern-fun-name - (make-method-spec temp - (method-qualifiers method) - (unparse-specializers - (method-specializers method)))) + (make-method-spec temp + (method-qualifiers method) + (unparse-specializers + (method-specializers method))) (make-symbol (format nil "~S" method)))) (multiple-value-bind (gf-spec quals specls) (parse-defmethod spec) @@ -2329,9 +2307,8 @@ bootstrapping. (and (setq method (get-method gf quals specls errorp)) (setq name - (intern-fun-name (make-method-spec gf-spec - quals - specls)))))))) + (make-method-spec + gf-spec quals (unparse-specializers specls)))))))) (values gf method name))) (defun extract-parameters (specialized-lambda-list) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index fa1a917..223eaae 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -59,9 +59,9 @@ (defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil) -(defmacro define-internal-pcl-function-name-syntax (name &rest rest) +(defmacro define-internal-pcl-function-name-syntax (name &body body) `(progn - (define-function-name-syntax ,name ,@rest) + (define-function-name-syntax ,name ,@body) (pushnew ',name sb-pcl::*internal-pcl-generalized-fun-name-symbols*))) (define-internal-pcl-function-name-syntax sb-pcl::class-predicate (list) @@ -79,6 +79,15 @@ (symbolp class)) (values t slot))))) +(define-internal-pcl-function-name-syntax sb-pcl::fast-method (list) + (valid-function-name-p (cadr list))) + +;;; FIXME: I don't like this name, because though it looks nice and +;;; internal, it is in fact CL:METHOD, and as such has a slight +;;; implication of supportedness. +(define-internal-pcl-function-name-syntax sb-pcl::method (list) + (valid-function-name-p (cadr list))) + (defun sb-pcl::random-documentation (name type) (cdr (assoc type (info :random-documentation :stuff name)))) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 021c50e..deda8ec 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -165,13 +165,6 @@ (defmacro std-instance-class (instance) `(wrapper-class* (std-instance-wrapper ,instance))) -;;; When given a function should give this function the name -;;; NEW-NAME. Note that NEW-NAME is sometimes a list. Some lisps -;;; get the upset in the tummy when they start thinking about -;;; functions which have lists as names. To deal with that there is -;;; SET-FUN-NAME-INTERN which takes a list spec for a function -;;; name and turns it into a symbol if need be. -;;; ;;; When given a funcallable instance, SET-FUN-NAME *must* side-effect ;;; that FIN to give it the name. When given any other kind of ;;; function SET-FUN-NAME is allowed to return a new function which is @@ -180,51 +173,25 @@ ;;; In all cases, SET-FUN-NAME must return the new (or same) ;;; function. (Unlike other functions to set stuff, it does not return ;;; the new value.) -(defun set-fun-name (fcn new-name) +(defun set-fun-name (fun new-name) #+sb-doc "Set the name of a compiled function object. Return the function." (declare (special *boot-state* *the-class-standard-generic-function*)) - (cond ((symbolp fcn) - (set-fun-name (symbol-function fcn) new-name)) - ((funcallable-instance-p fcn) - (if (if (eq *boot-state* 'complete) - (typep fcn 'generic-function) - (eq (class-of fcn) *the-class-standard-generic-function*)) - (setf (%funcallable-instance-info fcn 1) new-name) - (bug "unanticipated function type")) - fcn) - (t - ;; pw-- This seems wrong and causes trouble. Tests show - ;; that loading CL-HTTP resulted in ~5400 closures being - ;; passed through this code of which ~4000 of them pointed - ;; to but 16 closure-functions, including 1015 each of - ;; DEFUN MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION - ;; DEFUN MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION - ;; DEFUN MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION. - ;; Since the actual functions have been moved by PURIFY - ;; to memory not seen by GC, changing a pointer there - ;; not only clobbers the last change but leaves a dangling - ;; pointer invalid after the next GC. Comments in low.lisp - ;; indicate this code need do nothing. Setting the - ;; function-name to NIL loses some info, and not changing - ;; it loses some info of potential hacking value. So, - ;; lets not do this... - #+nil - (let ((header (%closure-fun fcn))) - (setf (%simple-fun-name header) new-name)) - - ;; XXX Maybe add better scheme here someday. - fcn))) - -(defun intern-fun-name (name) - (cond ((symbolp name) name) - ((listp name) - (let ((*package* *pcl-package*) - (*print-case* :upcase) - (*print-pretty* nil) - (*print-gensym* t)) - (format-symbol *pcl-package* "~S" name))))) - + (when (valid-function-name-p fun) + (setq fun (fdefinition fun))) + (when (funcallable-instance-p fun) + (if (if (eq *boot-state* 'complete) + (typep fun 'generic-function) + (eq (class-of fun) *the-class-standard-generic-function*)) + (setf (%funcallable-instance-info fun 1) new-name) + (bug "unanticipated function type"))) + ;; Fixup name-to-function mappings in cases where the function + ;; hasn't been defined by DEFUN. (FIXME: is this right? This logic + ;; comes from CMUCL). -- CSR, 2004-12-31 + (when (and (consp new-name) + (member (car new-name) '(method fast-method slot-accessor))) + (setf (fdefinition new-name) fun)) + fun) ;;; FIXME: probably no longer needed after init (defmacro precompile-random-code-segments (&optional system) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 7403d3a..9a8f51d 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -1044,7 +1044,7 @@ (defun name-method-lambda (method-lambda) (let ((method-name (body-method-name (cddr method-lambda)))) (if method-name - `(named-lambda ,method-name ,(rest method-lambda)) + `(named-lambda (method ,method-name) ,(rest method-lambda)) method-lambda))) (defun make-method-initargs-form-internal (method-lambda initargs env) @@ -1093,7 +1093,8 @@ :fast-function (,(if (body-method-name body) 'named-lambda 'lambda) ,@(when (body-method-name body) - (list (body-method-name body))) ; function name + ;; function name + (list (cons 'fast-method (body-method-name body)))) (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args ;; body of the function (declare (ignorable .pv-cell. .next-method-call.)) diff --git a/version.lisp-expr b/version.lisp-expr index e628409..1ebf629 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.18.7" +"0.8.18.8"