Ignore:
Timestamp:
Jul 26, 2009, 1:24:19 PM (10 years ago)
Author:
gz
Message:

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods, return object for eql-specializer

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/source-files.lisp

    r12335 r12463  
    3838  (:method ((thing method-function)) (name-of (%method-function-method thing)))
    3939  (:method ((thing function)) (name-of (function-name thing)))
    40   (:method ((thing method)) (method-name thing))
     40  (:method ((thing method)) `(:method ,(method-name thing) ,@(method-qualifiers thing) ,(method-specializers thing)))
    4141  (:method ((thing class)) (class-name thing))
    4242  (:method ((thing method-combination)) (method-combination-name thing))
    43   (:method ((thing package)) (package-name thing)))
     43  (:method ((thing package)) (package-name thing))
     44  (:method ((thing eql-specializer)) `(eql ,(eql-specializer-object thing))))
    4445
    4546;; This used to be weak, but the keys are symbols-with-definitions, so why bother.
     
    452453          (class
    453454             (setq implicit-type 'class implicit-name (name-of name)))
    454           (t
    455              (setq implicit-type t implicit-name name)))
     455          (t
     456           (locally
     457               (declare (ftype function xref-entry-p xref-entry-full-name xref-entry-type))
     458             (if (and (find-class 'xref-entry nil)
     459                      (xref-entry-p name))
     460               (setq implicit-type (xref-entry-type name) implicit-name (xref-entry-full-name name))
     461               (setq implicit-type t implicit-name name)))))
    456462        (setq implicit-dt-class (class-of (definition-type-instance implicit-type)))
    457463        (with-lock-grabbed (*source-files-lock*)
     
    485491;;; not instances
    486492(defun %my-method-applicable-p (method args cpls)
    487   (do ((specs (%method-specializers method) (cdr specs))
    488        (args args (cdr args))
    489        (cpls cpls (cdr cpls)))
    490       ((null specs) t)
    491     (declare (type list specs args cpls))
    492     (let ((spec (car specs)))
    493       (if (listp spec)
    494         (unless (equal (car args) spec)
    495           (return nil))
    496         (unless (memq spec (car cpls))
     493  (do* ((specs (%method-specializers method) (%cdr specs))
     494        (args args (%cdr args))
     495        (cpls cpls (%cdr cpls)))
     496      ((null args) t)
     497    (let ((spec (%car specs))
     498          (arg (%car args)))
     499      (if (typep spec 'eql-specializer)
     500        (if (consp arg)
     501          (unless (eql (cadr arg) (eql-specializer-object spec))
     502            (return nil))
     503          (if (typep (eql-specializer-object spec) arg)
     504            ;(unless (eq arg *null-class*) (return :undecidable))
     505            t  ;; include if it's at all possible it might be applicable.
     506            (return nil)))
     507        (unless (memq spec (%car cpls))
    497508          (return nil))))))
    498509
     
    503514  (let ((gf (fboundp name)))
    504515    (when (and gf (typep gf 'standard-generic-function))
    505       (let* ((methods (%gf-methods gf))
     516      (let* ((methods (or (%gf-methods gf)
     517                          (return-from find-applicable-methods nil)))
     518             (arg-count (length (%method-specializers (car methods))))
    506519             (args-length (length args))
    507              (bits (lfun-bits (closure-function gf)))  ; <<
    508              arg-count res)
    509         (when methods
    510           (setq arg-count (length (%method-specializers (car methods))))
    511           (unless (or (logbitp $lfbits-rest-bit bits)
    512                       (logbitp $lfbits-keys-bit bits)
    513                       (<= args-length
    514                           (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
    515             (return-from find-applicable-methods))
    516           (cond
    517            ((null args)
    518             (dolist (m methods res)
    519               (when (or (eq qualifiers t)
    520                         (equal qualifiers (%method-qualifiers m)))
    521                 (push m res))))
    522            ((%i< args-length arg-count)
    523             (let (spectails)
    524               (dolist (m methods)
    525                 (let ((mtail (nthcdr args-length (%method-specializers m))))
    526                   (pushnew mtail spectails :test #'equal)))
    527               (dolist (tail spectails)
    528                 (setq res
    529                       (nconc res (find-applicable-methods
    530                                   name
    531                                   (append args (mapcar
    532                                                 #'(lambda (x) (if (consp x) x (class-name x)))
    533                                                 tail))
    534                                   qualifiers))))
    535               (if (%cdr spectails)
    536                 (delete-duplicates res :from-end t :test #'eq)
    537                 res)))
    538            (t
    539             (let ((cpls (make-list arg-count)))
    540               (declare (dynamic-extent cpls))
    541               (do ((args-tail args (cdr args-tail))
    542                    (cpls-tail cpls (cdr cpls-tail)))
    543                   ((null cpls-tail))
    544                 (declare (type list args-tail cpls-tail))
    545                 (let ((arg (car args-tail)) thing)
    546                   (typecase arg
    547                     (cons
    548                        (setq thing (class-of (cadr arg))))
    549                     (symbol
    550                        (setq thing (find-class (or arg t) nil)))
    551                     (eql-specializer
    552                        (setq thing (class-of (eql-specializer-object arg))))
    553                     (t
    554                        (setq thing arg)))
    555                   (when thing
    556                     (setf (car cpls-tail)               
    557                           (%class-precedence-list thing)))))
    558               (dolist (m methods)
    559                 (when (%my-method-applicable-p m args cpls)
    560                   (push m res)))
    561               (let ((methods (sort-methods res cpls (%gf-precedence-list gf))))
    562                 (when (eq (generic-function-method-combination gf)
    563                           *standard-method-combination*)
    564                   ; around* (befores) (afters) primaries*
    565                   (setq methods (compute-method-list methods))
    566                   (when methods
    567                     (setq methods
    568                           (if (not (consp methods))
    569                             (list methods)
    570                             (let ((afters (cadr (member-if #'listp methods))))
    571                               (when afters (nremove afters methods))
    572                               (nconc
    573                                (mapcan #'(lambda (x)(if (listp x) x (cons x nil)))
    574                                        methods)
    575                                afters))))))
    576                 (if (and qualifiers (neq qualifiers t))
    577                   (delete-if #'(lambda (m)(not (equal qualifiers (%method-qualifiers m))))
    578                              methods)
    579                   methods))))))))))
     520             (bits (inner-lfun-bits gf))
     521             res)
     522        (unless (or (logbitp $lfbits-rest-bit bits)
     523                    (logbitp $lfbits-restv-bit bits)
     524                    (logbitp $lfbits-keys-bit bits)
     525                    (<= args-length
     526                        (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
     527                                        ;(error "Too many args for ~s" gf)
     528          (return-from find-applicable-methods))
     529        (when (< arg-count args-length)
     530          (setq args (subseq args 0 (setq args-length arg-count))))
     531        (setq args (mapcar (lambda (arg)
     532                             (typecase arg
     533                               (eql-specializer `(eql ,(eql-specializer-object arg)))
     534                               (class arg)
     535                               (symbol (or (find-class (or arg t) nil)
     536                                           ;;(error "Invalid class name ~s" arg)
     537                                           (return-from find-applicable-methods)))
     538                               (t
     539                                  (unless (and (consp arg) (eql (car arg) 'eql) (null (cddr arg)))
     540                                    ;;(error "Invalid specializer ~s" arg)
     541                                    (return-from find-applicable-methods))
     542                                  arg)))
     543                           args))
     544        (let ((cpls (make-list args-length)))
     545          (declare (dynamic-extent cpls))
     546          (do ((args-tail args (cdr args-tail))
     547               (cpls-tail cpls (cdr cpls-tail)))
     548              ((null cpls-tail))
     549            (declare (type list args-tail cpls-tail))
     550            (let ((arg (car args-tail)))
     551              (setf (car cpls-tail)
     552                    (%class-precedence-list (if (consp arg)
     553                                              (class-of (cadr arg))
     554                                              arg)))))
     555          (dolist (m methods)
     556            (when (%my-method-applicable-p m args cpls)
     557              (push m res)))
     558          (let ((methods (sort-methods res cpls (%gf-precedence-list gf))))
     559            (when (eq (generic-function-method-combination gf)
     560                      *standard-method-combination*)
     561                                        ; around* (befores) (afters) primaries*
     562              (setq methods (compute-method-list methods))
     563              (when methods
     564                (setq methods
     565                      (if (not (consp methods))
     566                        (list methods)
     567                        (let ((afters (cadr (member-if #'listp methods))))
     568                          (when afters (nremove afters methods))
     569                          (nconc
     570                           (mapcan #'(lambda (x)(if (listp x) x (cons x nil)))
     571                                   methods)
     572                           afters))))))
     573            (if (and qualifiers (neq qualifiers t))
     574              (delete-if #'(lambda (m)(not (equal qualifiers (%method-qualifiers m))))
     575                         methods)
     576              methods)))))))
    580577
    581578;;; Do this just in case record source file doesn't remember the right
     
    653650    (let (name quals specs data last)
    654651      (when (consp m)
     652        (when (eq (car m) :method) (setq m (cdr m)))
    655653        ;; (name spec1 .. specn) or (name qual1 .. qualn (spec1 ... specn))
    656654        (setq data (cdr m) last (last data))
Note: See TracChangeset for help on using the changeset viewer.