Changeset 12408


Ignore:
Timestamp:
Jul 14, 2009, 6:38:06 AM (10 years ago)
Author:
gz
Message:

Some changes in support of Slime:

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

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.

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)

Location:
branches/working-0711/ccl
Files:
20 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/nx-basic.lisp

    r12348 r12408  
    424424                 (if (non-nil-symbol-p spec)
    425425                   (setq fname spec)
    426                    (if (and (consp spec) (eq (%car spec) 'setf))
     426                   (if (setf-function-name-p spec)
    427427                     (setq fname (setf-function-name (cadr spec)))))
    428428                 (if fname
     
    444444                     (if (not (non-nil-symbol-p fname))
    445445                       (setq fname
    446                              (if (and (consp fname) (eq (%car fname) 'setf))
     446                             (if (setf-function-name-p fname)
    447447                               (setf-function-name (cadr fname)))))
    448448                     (if fname (push (list* fname decltype t) fdecls)))))))
     
    453453                           (if (not (non-nil-symbol-p fname))
    454454                             (setq fname
    455                                    (if (and (consp fname) (eq (%car fname) 'setf))
     455                                   (if (setf-function-name-p fname)
    456456                                     (setf-function-name (cadr fname)))))
    457457                           (if fname (push (list* fname decltype typespec) fdecls))))))
     
    528528       ,@body))))
    529529
     530
     531;; Should be true if compiler warnings UI doesn't use source locations, false if it does.
     532(defvar *merge-compiler-warnings* t "If false, don't merge compiler warnings with different source locations")
     533
    530534;;; If warnings have more than a single entry on their
    531535;;; args slot, don't merge them.
     
    536540        (if
    537541          (or (cdr w-args)
     542              ;; See if W can be merged into an existing warning
    538543              (dolist (w1 warnings t)
    539544                (let ((w1-args (compiler-warning-args w1)))
     
    543548                             (null (cdr w1-args))
    544549                             (eq (%car w-args)
    545                                  (%car w1-args)))
     550                                 (%car w1-args))
     551                             (or *merge-compiler-warnings*
     552                                 (eq (compiler-warning-source-note w)
     553                                     (compiler-warning-source-note w1))))
    546554                    (let ((nrefs (compiler-warning-nrefs w1)))
    547555                      #-BOOTSTRAPPED (when (eql nrefs 1) (setq nrefs nil))
     
    549557                            (cons (compiler-warning-source-note w)
    550558                                  (or nrefs
    551                                       (list (compiler-warning-source-note w1))))))
    552                     (return)))))
     559                                      (list (compiler-warning-source-note w1)))))
     560                      (return nil))))))
    553561          (push w warnings))))
    554562    warnings))
     
    645653
    646654
    647 (defun report-compiler-warning (condition stream)
     655(defun report-compiler-warning (condition stream &key short)
    648656  (let* ((warning-type (compiler-warning-warning-type condition))
    649657         (format-string (cdr (assq warning-type *compiler-warning-formats*)))
    650          (name (reverse (compiler-warning-function-name condition))))
    651     (format stream "In ")
    652     (print-nested-name name stream)
    653     (when (every #'null name)
    654       (let ((position (compiler-warning-stream-position condition)))
    655         (when position (format stream " at position ~s" position))))
    656     (format stream ": ")
     658         (warning-args (compiler-warning-args condition)))
     659    (unless short
     660      (let ((name (reverse (compiler-warning-function-name condition))))
     661        (format stream "In ")
     662        (print-nested-name name stream)
     663        (when (every #'null name)
     664          (let ((position (source-note-start-pos (compiler-warning-source-note condition))))
     665            (when position (format stream " at position ~s" position))))
     666        (format stream ": ")))
    657667    (if (typep format-string 'string)
    658       (apply #'format stream format-string (adjust-compiler-warning-args warning-type (compiler-warning-args condition)))
     668      (apply #'format stream format-string (adjust-compiler-warning-args warning-type warning-args))
    659669      (if (null format-string)
    660         (format stream "~A: ~S" warning-type (compiler-warning-args condition))
     670        (format stream "~A: ~S" warning-type warning-args)
    661671        (funcall format-string condition stream)))
    662672    ;(format stream ".")
  • branches/working-0711/ccl/level-1/l1-aprims.lisp

    r12202 r12408  
    244244
    245245(defun setf-function-name (sym)
     246  "Returns the symbol in the SETF package that holds the binding of (SETF sym)"
    246247   (or (gethash sym %setf-function-names%)
    247248       (progn
     
    298299
    299300(defun maybe-setf-function-name (name)
    300   (if (and (consp name) (eq (car name) 'setf))
     301  (if (setf-function-name-p name)
    301302    (setf-function-name (cadr name))
    302303    name))
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r12048 r12408  
    35923592  (%compute-applicable-methods* gf args))
    35933593
     3594(defmethod compute-applicable-methods-using-classes ((gf standard-generic-function) args)
     3595  (let ((res (%compute-applicable-methods* gf args t)))
     3596    (if (eq res :undecidable)
     3597      (values nil nil)
     3598      (values res t))))
     3599
    35943600(defun %compute-applicable-methods+ (gf &rest args)
    35953601  (declare (dynamic-extent args))
    35963602  (%compute-applicable-methods* gf args))
    35973603
    3598 (defun %compute-applicable-methods* (gf args)
     3604(defun %compute-applicable-methods* (gf args &optional using-classes-p)
    35993605  (let* ((methods (%gf-methods gf))
    36003606         (args-length (length args))
     
    36173623            ((null cpls-tail))
    36183624          (setf (car cpls-tail)
    3619                 (%class-precedence-list (class-of (car args-tail)))))
     3625                (%class-precedence-list (if using-classes-p
     3626                                          ;; extension for use in source location support
     3627                                          (if (typep (car args-tail) 'eql-specializer)
     3628                                            (class-of (eql-specializer-object (car args-tail)))
     3629                                            (car args-tail))
     3630                                          (class-of (car args-tail))))))
    36203631        (dolist (m methods)
    3621           (if (%method-applicable-p m args cpls)
    3622             (push m res)))
     3632          (let ((appp (%method-applicable-p m args cpls using-classes-p)))
     3633            (when appp
     3634              (when (eq appp :undecidable) ;; can only happen if using-classes-p
     3635                (return-from %compute-applicable-methods* appp))
     3636              (push m res))))
    36233637        (sort-methods res cpls (%gf-precedence-list gf))))))
    36243638
    36253639
    3626 (defun %method-applicable-p (method args cpls)
     3640(defun %method-applicable-p (method args cpls &optional using-classes-p)
    36273641  (do* ((specs (%method-specializers method) (%cdr specs))
    36283642        (args args (%cdr args))
    36293643        (cpls cpls (%cdr cpls)))
    36303644      ((null specs) t)
    3631     (let ((spec (%car specs)))
     3645    (let ((spec (%car specs))
     3646          (arg (%car args)))
    36323647      (if (typep spec 'eql-specializer)
    3633         (unless (eql (%car args) (eql-specializer-object spec))
    3634           (return nil))
     3648        (if using-classes-p
     3649          (if (typep arg 'eql-specializer) ;; extension for use in source location support
     3650            (unless (eql (eql-specializer-object arg) (eql-specializer-object spec))
     3651              (return nil))
     3652            (if (typep (eql-specializer-object spec) arg)
     3653              ;; Can't tell if going to be applicable or not based on class alone
     3654              ;; Except for the special case of NULL which is a singleton
     3655              (unless (eq arg *null-class*)
     3656                (return :undecidable))
     3657              (return nil)))
     3658          (unless (eql arg (eql-specializer-object spec))
     3659            (return nil)))
    36353660        (unless (memq spec (%car cpls))
    36363661          (return nil))))))
  • branches/working-0711/ccl/level-1/l1-error-system.lisp

    r12186 r12408  
    6363
    6464(define-condition compiler-warning (warning)
    65   ((file-name :initarg :file-name :initform nil :accessor compiler-warning-file-name)
    66    (stream-position :initform nil :accessor compiler-warning-stream-position)
    67    (function-name :initarg :function-name :initform nil :accessor compiler-warning-function-name)
     65  ((function-name :initarg :function-name :initform nil :accessor compiler-warning-function-name)
    6866   (source-note :initarg :source-note :initform nil :accessor compiler-warning-source-note)
    6967   (warning-type :initarg :warning-type :reader compiler-warning-warning-type)
     
    7169   (nrefs :initform () :accessor compiler-warning-nrefs))
    7270  (:report report-compiler-warning))
     71
     72;; Backward compatibility
     73(defmethod compiler-warning-file-name ((w compiler-warning))
     74  (source-note-filename (compiler-warning-source-note w)))
    7375
    7476(define-condition style-warning (compiler-warning)
  • branches/working-0711/ccl/level-1/l1-events.lisp

    r12186 r12408  
    108108                           (progv vars old-vals
    109109                             (mapcar (lambda (v f) (set v (funcall f))) vars inits)
    110                              (let ((condition (make-condition 'interrupt-signal-condition)))
     110                             (let ((condition (make-condition 'interrupt-signal-condition))
     111                                   (*top-error-frame* (%current-exception-frame)))
    111112                               (ignoring-without-interrupts
    112113                                 (when *invoke-debugger-hook-on-interrupt*
     
    115116                                     (when hook
    116117                                       (funcall hook condition hook))))
    117                                  (%break-in-frame
    118                                   #+ppc-target *fake-stack-frames*
    119                                   #+x86-target (or (let* ((xcf (%current-xcf)))
    120                                                      (if xcf
    121                                                        (%%frame-backlink xcf)))
    122                                                    (%get-frame-ptr))
    123                                   condition)
     118                                 (%break-in-frame *top-error-frame* condition)
    124119                                 (clear-input *terminal-io*))))))))
    125120
     
    143138  (thread-handle-interrupts))
    144139
    145 (defun select-interactive-abort-process (&aux proc)
    146   (or (and (setq proc *interactive-abort-process*)
    147            (process-active-p proc)
    148            proc)
    149       (let* ((sr (input-stream-shared-resource *terminal-input*)))
    150         (when sr
    151           (or (and (setq proc (shared-resource-current-owner sr))
    152                    (process-active-p proc)
    153                    proc)
    154               (and (setq proc (shared-resource-primary-owner sr))
    155                    (process-active-p proc)
    156                    proc))))))
     140
     141(defvar *select-interactive-process-hook* nil)
     142
     143(defun select-interactive-abort-process ()
     144  (flet ((maybe-proc (proc) (and proc (process-active-p proc) proc)))
     145    (or (maybe-proc (and *select-interactive-process-hook*
     146                         (funcall *select-interactive-process-hook*)))
     147        (maybe-proc *interactive-abort-process*)
     148        (let* ((sr (input-stream-shared-resource *terminal-input*)))
     149          (when sr
     150            (or (maybe-proc (shared-resource-current-owner sr))
     151                (maybe-proc (shared-resource-primary-owner sr))))))))
    157152
    158153(defun handle-gc-hooks ()
  • branches/working-0711/ccl/level-1/l1-lisp-threads.lisp

    r12204 r12408  
    556556  (%current-frame-ptr))
    557557
    558 
    559 
     558(defun %current-exception-frame ()
     559  #+ppc-target *fake-stack-frames*
     560  #+x86-target (or (let* ((xcf (%current-xcf)))
     561                     (if xcf
     562                       (%%frame-backlink xcf)))
     563                   (%current-frame-ptr)))
    560564
    561565
  • branches/working-0711/ccl/level-1/l1-readloop-lds.lisp

    r12236 r12408  
    471471  (#__exit -1))
    472472
    473 (defun break-loop-handle-error (condition error-pointer)
     473(defvar *top-error-frame* nil)
     474
     475(defun break-loop-handle-error (condition *top-error-frame*)
    474476  (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals)
    475477    (dolist (x bogus-globals)
     
    479481            (*debugger-hook* nil))
    480482        (funcall hook condition hook)))
    481     (%break-message "Error" condition error-pointer)
     483    (%break-message "Error" condition)
    482484    (let* ((s *error-output*))
    483485      (dolist (bogusness bogus-globals)
     
    489491          (format s ", was reset to ~s ." (symbol-value bogusness)))))
    490492    (if (and *break-on-errors* (not *batch-flag*))
    491       (break-loop condition error-pointer)
     493      (break-loop condition)
    492494      (if *batch-flag*
    493495        (abnormal-application-exit)
     
    522524
    523525
    524 (defun invoke-debugger (condition &aux (fp (%get-frame-ptr)))
     526(defun invoke-debugger (condition &aux (*top-error-frame* (%get-frame-ptr)))
    525527  "Enter the debugger."
    526528  (let ((c (require-type condition 'condition)))
     
    529531            (*debugger-hook* nil))
    530532        (funcall hook c hook)))
    531     (%break-message "Debug" c fp)
    532     (break-loop c fp)))
    533 
    534 (defun %break-message (msg condition error-pointer &optional (prefixchar #\>))
     533    (%break-message "Debug" c)
     534    (break-loop c)))
     535
     536(defun %break-message (msg condition &optional (error-pointer *top-error-frame*) (prefixchar #\>))
    535537  (let ((*print-circle* *error-print-circle*)
    536538        ;(*print-prett*y nil)
     
    562564(defvar *break-hook* nil)
    563565
    564 (defun cbreak-loop (msg cont-string condition error-pointer)
     566(defun cbreak-loop (msg cont-string condition *top-error-frame*)
    565567  (let* ((*print-readably* nil)
    566568         (hook *break-hook*))
     
    570572                        (funcall hook condition hook))
    571573                      (setq hook nil))
    572                     (%break-message msg condition error-pointer)
    573                     (break-loop condition error-pointer))
     574                    (%break-message msg condition)
     575                    (when (and (eq (type-of condition) 'simple-condition)
     576                               (equal (simple-condition-format-control condition) ""))
     577                      (setq condition (make-condition 'simple-condition
     578                                        :format-control "~a"
     579                                        :format-arguments (list msg))))
     580                    (break-loop condition))
    574581      (continue () :report (lambda (stream) (write-string cont-string stream))))
    575582    (unless hook
     
    628635
    629636(defvar %last-continue% nil)
    630 (defun break-loop (condition frame-pointer)
     637(defun break-loop (condition &optional (frame-pointer *top-error-frame*))
    631638  "Never returns"
    632639  (let* ((%handlers% (last %handlers%)) ; firewall
  • branches/working-0711/ccl/level-1/l1-readloop.lisp

    r12236 r12408  
    683683                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
    684684                    (%function sym))
    685                    ((and (consp sym) (eq (%car sym) 'setf) (consp (%cdr sym)) (null (%cddr sym)))
     685                   ((setf-function-name-p sym)
    686686                    (multiple-value-bind (kind local-p)
    687687                        (function-information sym env)
  • branches/working-0711/ccl/level-1/sysutils.lisp

    r12048 r12408  
    583583                    (lambda (c)
    584584                      (let ((w2 (make-condition 'invalid-type-warning
    585                                   :file-name (compiler-warning-file-name w)
    586585                                  :function-name (compiler-warning-function-name w)
    587586                                  :source-note (compiler-warning-source-note w)
    588587                                  :warning-type :invalid-type
    589588                                  :args (list typespec c))))
    590                         (setf (compiler-warning-stream-position w2)
    591                               (compiler-warning-stream-position w))
    592589                        (return-from verify-deferred-type-warning w2)))))
    593590      (values-specifier-type typespec)
     
    615612                   (let* ((w2 (make-condition
    616613                               'invalid-arguments
    617                                :file-name (compiler-warning-file-name w)
    618614                               :function-name (compiler-warning-function-name w)
    619615                               :source-note (compiler-warning-source-note w)
    620616                               :warning-type deftype
    621617                               :args (list (car args) reason arglist spread-p))))
    622                      (setf (compiler-warning-stream-position w2)
    623                            (compiler-warning-stream-position w))
    624618                     w2))))))
    625619          ((def-info.macro-p (cdr def))
    626620           (let* ((w2 (make-condition
    627621                       'macro-used-before-definition
    628                        :file-name (compiler-warning-file-name w)
    629622                       :function-name (compiler-warning-function-name w)
    630623                       :source-note (compiler-warning-source-note w)
    631624                       :warning-type :macro-used-before-definition
    632625                       :args (list (car args)))))
    633              (setf (compiler-warning-stream-position w2)
    634                    (compiler-warning-stream-position w))
    635626             w2)))))
    636627
  • branches/working-0711/ccl/lib/backtrace-lds.lisp

    r11101 r12408  
    3131  #+ppc-target #(save7 save6 save5 save4 save3 save2 save1 save0))
    3232
     33(defun frame-function (frame context)
     34  "Returns the function using the frame, and pc offset within the function, if known"
     35  (declare (ignore context))
     36  (cfp-lfun (require-type frame 'integer)))
     37
     38(defun frame-supplied-arguments (frame context &key (unknown-marker (%unbound-marker)))
     39  "Return a list of supplied arguments to the call which opened this frame, as best we can reconstruct it"
     40  (multiple-value-bind (lfun pc) (cfp-lfun frame)
     41    (multiple-value-bind (args valid) (supplied-argument-list context frame lfun pc)
     42      (if (not valid)
     43        unknown-marker
     44        (if (eq unknown-marker (%unbound-marker))
     45          args
     46          (substitute unknown-marker (%unbound-marker) args))))))
     47
     48(defun frame-named-variables (frame context &key (unknown-marker (%unbound-marker)))
     49  "Returns an alist of (NAME . VALUE) of all named variables in this frame."
     50  (multiple-value-bind (lfun pc) (cfp-lfun frame)
     51    (multiple-value-bind (args locals) (arguments-and-locals context frame lfun pc unknown-marker)
     52      (if (eq unknown-marker (%unbound-marker))
     53        (append args locals)
     54        (substitute unknown-marker (%unbound-marker) (append args locals))))))
     55
     56
     57(defun frame-arguments-and-locals (frame context &key unknown-marker)
     58  "Return two values, the arguments and the locals, known for this frame, as alists of (name . value)"
     59  (multiple-value-bind (lfun pc) (cfp-lfun frame)
     60    (arguments-and-locals context frame lfun pc unknown-marker)))
    3361
    3462;;; Returns three values: (ARG-VALUES TYPES NAMES), solely for the benefit
     
    3967;;;   cares about whether this is equal to "keyword" or not.
    4068;;; NAMES is a list of symbols which name the args.
     69;; 7/13/2009: This is now deprecated.  Use frame-supplied-arguments.
    4170(defun frame-supplied-args (frame lfun pc child context)
    4271  (declare (ignore child))
     
    4574    (if (<= pc target::arg-check-trap-pc-limit)
    4675      (values (arg-check-call-arguments frame lfun) nil nil)
    47       (let* ((arglist (arglist-from-map lfun))
    48              (args (arguments-and-locals context frame lfun pc))
    49              (state :required))
    50         (collect ((arg-values)
    51                   (types)
    52                   (names))
    53           (dolist (arg arglist)
    54             (if (or (member arg lambda-list-keywords)
    55                     (eq arg '&lexpr))
    56               (setq state arg)
    57               (let* ((pair (pop args)))
    58                 (case state
    59                   (&lexpr
    60                    (with-list-from-lexpr (rest (cdr pair))
    61                      (dolist (r rest) (arg-values r) (names nil) (types nil)))
    62                    (return))
    63                   (&rest
    64                    (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
    65                    (return))
    66                   (&key
    67                    (arg-values arg)
    68                    (names nil)
    69                    (types nil)))
    70                 (let* ((value (cdr pair)))
    71                   (if (eq value (%unbound-marker))
    72                     (return))
    73                   (names (car pair))
    74                   (arg-values value)
    75                   (types nil)))))
    76           (values (arg-values) (types) (names)))))))
     76      (multiple-value-bind (arglist valid) (arglist-from-map lfun)
     77        (if (not valid)
     78          (values nil nil nil)
     79          (let* ((args (arguments-and-locals context frame lfun pc))
     80                 (state :required))
     81            (collect ((arg-values)
     82                      (types)
     83                      (names))
     84              (dolist (arg arglist)
     85                (if (or (member arg lambda-list-keywords)
     86                        (eq arg '&lexpr))
     87                  (setq state arg)
     88                  (let* ((pair (pop args)))
     89                    (case state
     90                      (&lexpr
     91                         (with-list-from-lexpr (rest (cdr pair))
     92                           (dolist (r rest) (arg-values r) (names nil) (types nil)))
     93                         (return))
     94                      (&rest
     95                         (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
     96                         (return))
     97                      (&key
     98                         (arg-values arg)
     99                         (names nil)
     100                         (types nil)))
     101                    (let* ((value (cdr pair)))
     102                      (if (eq value (%unbound-marker))
     103                        (return))
     104                      (names (car pair))
     105                      (arg-values value)
     106                      (types nil)))))
     107              (values (arg-values) (types) (names)))))))))
    77108
    78109
  • branches/working-0711/ccl/lib/backtrace.lisp

    r12190 r12408  
    6161The arguments are represented by strings, the function is a symbol or a function
    6262object."
    63   (when (null count) (setq count target::target-most-positive-fixnum))
    64   (when (and context process (neq (bt.tcr context) (process-tcr process)))
    65     (error "Context ~s doesn't correspond to the process ~s" context process))
    66   (let* ((tcr (cond (context (bt.tcr context))
    67                     (process (process-tcr process))
    68                     (t (%current-tcr))))
    69          (*backtrace-print-level* print-level)
     63  (let* ((*backtrace-print-level* print-level)
    7064         (*backtrace-print-length* print-length)
    71          (*backtrace-show-internal-frames* show-internal-frames)
    72          (*backtrace-format* :list))
    73     (if (eq tcr (%current-tcr))
    74       (%backtrace-as-list-internal context (or origin (%get-frame-ptr)) count start-frame-number)
    75       (unwind-protect
    76            (progn
    77              (%suspend-tcr tcr)
    78              (unless context
    79                (setq context (context-for-suspended-tcr tcr)))
    80              (%backtrace-as-list-internal context (or origin (bt.current context)) count start-frame-number))
    81         (%resume-tcr tcr)))))
    82 
    83 
    84 ;;; This PRINTS the call history on *DEBUG-IO*.  It's more dangerous
    85 ;;; (because of stack consing) to actually return it.
    86                                
     65         (*backtrace-format* :list)
     66         (result nil))
     67    (map-call-frames (lambda (p context)
     68                       (multiple-value-bind (lfun pc) (cfp-lfun p)
     69                         (push (if lfun
     70                                 (backtrace-call-arguments context p lfun pc)
     71                                 "?????")
     72                               result)))
     73                     :context context
     74                     :process process
     75                     :origin origin
     76                     :count count
     77                     :start-frame-number start-frame-number
     78                     :test (and (not show-internal-frames) 'function-frame-p))
     79    (nreverse result)))
     80
    8781(defun print-call-history (&key context
    8882                                process
     
    9690                                (show-internal-frames *backtrace-show-internal-frames*)
    9791                                (format *backtrace-format*))
    98   (when (null count) (setq count target::target-most-positive-fixnum))
     92  (let ((*backtrace-print-level* print-level)
     93        (*backtrace-print-length* print-length)
     94        (*backtrace-format* format)
     95        (*standard-output* stream)
     96        (*print-circle* nil)
     97        (frame-number (or start-frame-number 0)))
     98    (map-call-frames (lambda (p context)
     99                       (multiple-value-bind (lfun pc) (cfp-lfun p)
     100                         (unless (and (typep detailed-p 'fixnum)
     101                                      (not (= (the fixnum detailed-p) frame-number)))
     102                           (%show-stack-frame-label frame-number p context lfun pc detailed-p)
     103                           (when detailed-p
     104                             (if (eq detailed-p :raw)
     105                               (%show-stack-frame p context lfun pc)
     106                               (%show-args-and-locals p context lfun pc)))
     107                           (incf frame-number))))
     108                     :context context
     109                     :process process
     110                     :origin origin
     111                     :count count
     112                     :start-frame-number start-frame-number
     113                     :test (and (not show-internal-frames) 'function-frame-p))
     114    (values)))
     115
     116(defun function-frame-p (p context)
     117  (and (not (catch-csp-p p context)) (cfp-lfun p)))
     118
     119(defun map-call-frames (fn &key context
     120                           process
     121                           origin
     122                           (count target::target-most-positive-fixnum)
     123                           (start-frame-number 0)
     124                           test)
    99125  (when (and context process (neq (bt.tcr context) (process-tcr process)))
    100126    (error "Context ~s doesn't correspond to the process ~s" context process))
    101   (let* ((tcr (cond (context (bt.tcr context))
    102                     (process (process-tcr process))
    103                     (t (%current-tcr))))
    104          (*backtrace-print-level* print-level)
    105          (*backtrace-print-length* print-length)
    106          (*backtrace-show-internal-frames* show-internal-frames)
    107          (*backtrace-format* format))
     127  (let ((tcr (cond (context (bt.tcr context))
     128                   (process (process-tcr process))
     129                   (t (%current-tcr))))
     130        (*print-catch-errors* t)
     131        (*signal-printing-errors* nil))
    108132    (if (eq tcr (%current-tcr))
    109       (%print-call-history-internal context (or origin (%get-frame-ptr)) detailed-p count start-frame-number stream)
    110       (unwind-protect
    111            (progn
    112              (%suspend-tcr tcr)
    113              (unless context
    114                (setq context (context-for-suspended-tcr tcr)))
    115              (%print-call-history-internal context (or origin (bt.current context)) detailed-p count start-frame-number stream))
    116         (%resume-tcr tcr)))
    117     (values)))
    118 
    119 (defun map-call-frames (fn &key context
    120                            (origin (%get-frame-ptr))
    121                            (start-frame-number 0)
    122                            (include-internal nil))
    123   (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
    124     (if (eq tcr (%current-tcr))
    125       (%map-call-frames-internal fn context origin include-internal start-frame-number)
     133      (%map-call-frames-internal fn context (or origin (%get-frame-ptr)) count start-frame-number test)
    126134      (unwind-protect
    127135           (progn
    128136             (%suspend-tcr tcr)
    129              (%map-call-frames-internal fn context origin include-internal start-frame-number))
     137             (when (null context)
     138               (setq context (context-for-suspended-tcr tcr)))
     139             (%map-call-frames-internal fn context (or origin (bt.current context))  count start-frame-number test))
    130140        (%resume-tcr tcr))))
    131141  nil)
    132142
     143; RAW case
    133144(defun %show-stack-frame (p context lfun pc)
    134145  (handler-case
     
    200211
    201212(defun backtrace-supplied-args (context frame lfun pc)
    202   (if (and pc (<= pc target::arg-check-trap-pc-limit))
    203     (arg-check-call-arguments frame lfun)
    204     (multiple-value-bind (params valid) (arglist-from-map lfun)
    205       (if (not valid)
    206         '("???")
    207         (let ((args (arguments-and-locals context frame lfun pc)) ;overkill, but will do.
    208               (state :required)
    209               (strings ()))
    210           (flet ((collect (arg)
    211                    (let* ((*print-length* *backtrace-print-length*)
    212                           (*print-level* *backtrace-print-level*))
    213                      (push (format nil "~s" arg) strings))))
    214             (dolist (param params)
    215               (if (or (member param lambda-list-keywords) (eq param '&lexpr))
    216                 (setq state param)
    217                 (let* ((pair (pop args))
    218                        (value (cdr pair)))
    219                   (case state
    220                     (&lexpr
    221                        (with-list-from-lexpr (rest value)
    222                          (dolist (r rest) (collect r)))
    223                        (return))
    224                     (&rest
    225                        (dolist (r value) (collect r))
    226                        (return))
    227                     (&key (collect param)))
    228                   (if (eq value (%unbound-marker))
    229                     (push "?" strings)
    230                     (collect value))))))
    231           (nreverse strings))))))
     213  (multiple-value-bind (args valid) (supplied-argument-list context frame lfun pc)
     214    (if (not valid)
     215      '("???")   
     216      (loop for arg in args
     217            collect (if (eq arg (%unbound-marker))
     218                      "?"
     219                      (let* ((*print-length* *backtrace-print-length*)
     220                             (*print-level* *backtrace-print-level*))
     221                        (format nil "~s" arg)))))))
    232222
    233223;;; Return a list of "interesting" frame addresses in context, most
     
    241231        (when (or (cfp-lfun p) include-internal)
    242232          (frames p))))))
    243    
    244 (defun %map-call-frames-internal (fn context origin include-internal skip-initial)
    245   (let ((*standard-output* *debug-io*)
    246         (*print-circle* nil)
    247         (p origin)
    248         (q (last-frame-ptr context)))
    249     (dotimes (i skip-initial)
    250       (setq p (parent-frame p context))
    251       (when (or (null p) (eq p q) (%stack< q p context))
    252         (return (setq p nil))))
    253     (do* ((p p (parent-frame p context)))
    254          ((or (null p) (eq p q) (%stack< q p context)) nil)
    255       (when (or include-internal
    256                 (and (not (catch-csp-p p context)) (cfp-lfun p)))
    257         (funcall fn p)))))
    258 
    259 (defun %backtrace-as-list-internal (context origin count skip-initial)
     233
     234(defun %map-call-frames-internal (fn context origin count skip-initial test)
     235  (when (null skip-initial) (setq skip-initial 0))
     236  (when (null count) (setq count target::target-most-positive-fixnum))
    260237  (unless (eq (last-frame-ptr context origin) (last-frame-ptr context))
    261238    (error "Origin ~s is not in the stack of ~s" origin context))
    262   (let ((*print-catch-errors* t)
    263         (p origin)
    264         (q (last-frame-ptr context)))
    265     (dotimes (i skip-initial)
    266       (setq p (parent-frame p context))
    267       (when (or (null p) (eq p q) (%stack< q p context))
    268         (return (setq p nil))))
    269     (do* ((frame-number (or skip-initial 0) (1+ frame-number))
    270           (i 0 (1+ i))
    271           (p p (parent-frame p context))
    272           (r '()))
    273         ((or (null p) (eq p q) (%stack< q p context)
    274              (>= i count))
    275          (nreverse r))
    276       (declare (fixnum frame-number i))
    277       (when (or (not (catch-csp-p p context))
    278                 *backtrace-show-internal-frames*)
    279         (multiple-value-bind (lfun pc) (cfp-lfun p)
    280           (when (or lfun *backtrace-show-internal-frames*)
    281             (push
    282              (if lfun
    283                (backtrace-call-arguments context p lfun pc)
    284                "?????")
    285              r)))))))
    286 
    287  
    288 (defun %print-call-history-internal (context origin detailed-p
    289                                              &optional (count target::target-most-positive-fixnum)
    290                                                        (skip-initial 0)
    291                                                        (stream *debug-io*))
    292   (unless (eq (last-frame-ptr context origin) (last-frame-ptr context))
    293     (error "Origin ~s is not in the stack of ~s" origin context))
    294   (let ((*standard-output* stream)
    295         (*print-circle* nil)
    296         (*print-catch-errors* t)
    297         (p origin)
    298         (q (last-frame-ptr context)))
    299     (dotimes (i skip-initial)
    300       (setq p (parent-frame p context))
    301       (when (or (null p) (eq p q) (%stack< q p context))
    302         (return (setq p nil))))
    303     (do* ((frame-number (or skip-initial 0) (1+ frame-number))
    304           (i 0 (1+ i))
    305           (p p (parent-frame p context)))
    306          ((or (null p) (eq p q) (%stack< q p context)
    307               (>= i count))
    308           (values))
    309       (declare (fixnum frame-number i))
    310       (when (or (not (catch-csp-p p context))
    311                 *backtrace-show-internal-frames*)
    312         (multiple-value-bind (lfun pc) (cfp-lfun p)
    313           (when (or lfun *backtrace-show-internal-frames*)
    314             (unless (and (typep detailed-p 'fixnum)
    315                          (not (= (the fixnum detailed-p) frame-number)))
    316               (%show-stack-frame-label frame-number p context lfun pc detailed-p)
    317               (when detailed-p
    318                 (if (eq detailed-p :raw)
    319                   (%show-stack-frame p context lfun pc)
    320                   (%show-args-and-locals p context lfun pc))))))))))
     239  (let ((q (last-frame-ptr context))
     240        (frame-number 0))
     241    (do ((p origin (parent-frame p context)))
     242        ((or (null p) (eq p q) (%stack< q p context) (<= count 0)) nil)
     243      (when (or (null test) (funcall test p context))
     244        (when (<= skip-initial frame-number)
     245          (funcall fn p context)
     246          (decf count))
     247        (incf frame-number)))))
    321248
    322249(defun %show-stack-frame-label (frame-number p context lfun pc detailed-p)
     
    686613              (dolist (name local-vars)
    687614                (get-local-value name)))))
    688         (values (args) (locals))))))
    689                    
    690            
     615           (values (args) (locals))))))
     616
     617;; Return list of supplied arguments, as best we can reconstruct it.
     618(defun supplied-argument-list (context frame lfun pc)
     619  (if (null pc)
     620    (values nil nil)
     621    (if (<= pc target::arg-check-trap-pc-limit)
     622      (values (arg-check-call-arguments frame lfun) t)
     623      (multiple-value-bind (params valid) (arglist-from-map lfun)
     624        (if (not valid)
     625          (values nil nil)
     626          (let* ((args (arguments-and-locals context frame lfun pc)) ;overkill, but will do.
     627                 (state :required)
     628                 (result ()))
     629            (dolist (param params)
     630              (if (or (member param lambda-list-keywords) (eq param '&lexpr))
     631                (setq state param)
     632                (let* ((pair (pop args))
     633                       (value (cdr pair)))
     634                  (case state
     635                    (&lexpr
     636                     (with-list-from-lexpr (rest value)
     637                       (dolist (r rest) (push r result)))
     638                     (return))
     639                    (&rest
     640                     (dolist (r value) (push r result))
     641                     (return))
     642                    (&key (push param result)))
     643                  (push value result))))
     644            (values (nreverse result) t)))))))
     645
    691646
    692647(defun safe-cell-value (val)
  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r12339 r12408  
    4242     find-definition-sources
    4343     define-definition-type
     44     definition-type
    4445     definition-type-name
    4546     *save-source-locations*
     
    5455     *record-pc-mapping*
    5556     find-source-note-at-pc
     57     caller-functions
    5658     *svn-program*
    5759     
     
    7476     *backtrace-show-internal-frames*
    7577     *backtrace-format*
     78     map-call-frames
     79     frame-function
     80     frame-supplied-arguments
     81     frame-named-variables
     82     apply-in-frame
    7683     *quit-on-eof*
    7784     *quit-interrupt-hook*
    7885     *break-hook*
     86     *top-error-frame*
     87     *select-interactive-process-hook*
    7988     interrupt-signal-condition
    8089     macroexpand-all
     
    8392     compile-user-function
    8493     uncompile-function
     94     report-compiler-warning
     95     compiler-warning
     96     style-warning
     97     compiler-warning-source-note
     98     compiler-warning-function-name
     99     *merge-compiler-warnings*
    85100     abort-break
    86101     *trace-print-level*
     
    94109     nfunction
    95110     function-name
     111     setf-function-p
     112     setf-function-spec-name
     113     name-of
    96114
    97115     assq
     
    194212     method-specializers
    195213     method-qualifiers
     214     slot-definition-documentation
    196215     slot-definition-allocation
    197216     slot-definition-initargs
     
    262281     *record-source-file*
    263282     *save-doc-strings*
     283     *fasl-save-doc-strings*
    264284     *warn-if-redefine*
    265285     *break-on-errors*
    266286     *save-definitions*
     287     *fasl-save-definitions*
    267288     *save-local-symbols*
    268289     *fasl-save-local-symbols*
     290     *save-arglist-info*
    269291     *always-eval-user-defvars*
    270292
     
    305327     with-filename-cstrs
    306328     get-foreign-namestring
     329     native-translated-namestring
     330     native-to-pathname
    307331     fasl-concatenate
    308332     event-ticks
     
    426450     *trace-max-indent*
    427451     *trace-level*
    428      *fasl-save-doc-strings*
    429      *fasl-save-definitions*
    430452     *static-cons-chunk*
    431453     static-cons
     
    435457     population-type
    436458     population-contents
     459
     460     hash-table-weak-p
    437461
    438462     compiler-let
     
    463487     make-process
    464488     process-suspend-count
     489     process-serial-number
    465490     process-initial-form
    466491     process-whostate
     
    471496     process-resume
    472497     process-suspend
     498     process-exhausted-p
    473499     let-globally
    474500     process-wait
     
    737763   "METHOD-SPECIALIZERS"
    738764   "METHOD-QUALIFIERS"
     765   "SLOT-DEFINITION-DOCUMENTATION"
    739766   "SLOT-DEFINITION-ALLOCATION"
    740767   "SLOT-DEFINITION-INITARGS"
     
    821848   "ENSURE-CLASS-USING-CLASS"
    822849   "ENSURE-GENERIC-FUNCTION-USING-CLASS"
     850   "EQL-SPECIALIZER"
    823851   "EQL-SPECIALIZER-OBJECT"
    824852   "EXTRACT-LAMBDA-LIST"
     
    843871   "METHOD-SPECIALIZERS"
    844872   "METHOD-QUALIFIERS"
     873   "SLOT-DEFINITION-DOCUMENTATION"
    845874   "SLOT-DEFINITION-ALLOCATION"
    846875   "SLOT-DEFINITION-INITARGS"
  • branches/working-0711/ccl/lib/describe.lisp

    r11775 r12408  
    1616
    1717(defpackage "INSPECTOR"
    18   (:use "CL" "CCL"))
     18  (:use "CL" "CCL")
     19  (:export "MAKE-INSPECTOR"
     20           "COMPUTE-LINE-COUNT"
     21           "LINE-N"
     22
     23           "*INSPECTOR-DISASSEMBLY*"))
     24
     25
    1926
    2027(in-package "INSPECTOR")
  • branches/working-0711/ccl/lib/edit-callers.lisp

    r12192 r12408  
    2323         (name (or name (ignore-errors (function-name thing)))))
    2424    (and name
    25          (or (not (or (symbolp name)(and (consp name)(eq (car name) 'setf)))) ; maybe its (setf baz)
     25         (or (not (or (symbolp name) (setf-function-name-p name))) ; maybe its (setf baz)
    2626             (let ((fn  (fboundp name)))
    2727               (and fn
  • branches/working-0711/ccl/lib/encapsulate.lisp

    r12191 r12408  
    6464
    6565(defun setf-function-spec-name (spec)
    66   (if (and (consp spec) (eq (car spec) 'setf))
    67     (or (%setf-method (cadr spec)) ; this can be an anonymous function
    68         (setf-function-name (cadr spec)))
     66  (if (setf-function-name-p spec)
     67    (let ((name (%setf-method (cadr spec))))
     68      (if (non-nil-symbol-p name)  ; this can be an anonymous function
     69        name
     70        (setf-function-name (cadr spec))))
    6971    spec))
    7072
  • branches/working-0711/ccl/lib/macros.lisp

    r12339 r12408  
    661661           (setq inline-spec spec)
    662662           (setq body `(block ,spec ,@forms)))
    663           ((and (consp spec) (eq 'setf (%car spec)))
     663          ((setf-function-name-p spec)
    664664           (setq inline-spec spec)
    665665           (setq body `(block ,(cadr spec) ,@forms)))
  • branches/working-0711/ccl/lib/nfcomp.lisp

    r12343 r12408  
    451451                          :external-format *fcomp-external-format*)
    452452    (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*))
    453            (*fasl-source-file* filename)
     453           (*fasl-source-file* (or orig-file filename))
    454454           (*fcomp-toplevel-forms* nil)
    455455           (*fasl-eof-forms* nil)
     
    468468          (let* ((*fcomp-stream-position* (file-position stream))
    469469                 (*nx-warnings* nil)) ;; catch any warnings from :compile-toplevel forms
     470            (when (and *fcomp-stream-position* orig-offset)
     471              (incf *fcomp-stream-position* orig-offset))
    470472            (unless (eq read-package *package*)
    471473              (fcomp-compile-toplevel-forms env)
     
    10741076        (harsh *fasl-non-style-warnings-signalled-p*))
    10751077    (dolist (w warnings)
    1076       (setf (compiler-warning-file-name w) *fasl-source-file*)
    1077       (setf (compiler-warning-stream-position w) *fcomp-stream-position*)
     1078      (unless (compiler-warning-source-note w)
     1079        (setf (compiler-warning-source-note w)
     1080              (make-source-note :source nil
     1081                                :filename *fasl-source-file*
     1082                                :start-pos *fcomp-stream-position*
     1083                                :end-pos *fcomp-stream-position*)))
    10781084      (if (and (typep w 'undefined-reference)
    10791085               (eq w (setq w (macro-too-late-p w env))))
     
    10991105                     (eq 'macro (cadr info)))))
    11001106          (make-instance 'macro-used-before-definition
    1101             :file-name (compiler-warning-file-name w)
     1107            :source-note (compiler-warning-source-note w)
    11021108            :function-name (compiler-warning-function-name w)
    11031109            :warning-type ':macro-used-before-definition
  • branches/working-0711/ccl/lib/source-files.lisp

    r12339 r12408  
    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))
     
    452452          (class
    453453             (setq implicit-type 'class implicit-name (name-of name)))
    454           (t
    455              (setq implicit-type t implicit-name name)))
     454          (t
     455           (locally
     456               (declare (ftype function xref-entry-p xref-entry-full-name xref-entry-type))
     457             (if (and (find-class 'xref-entry nil)
     458                      (xref-entry-p name))
     459               (setq implicit-type (xref-entry-type name) implicit-name (xref-entry-full-name name))
     460               (setq implicit-type t implicit-name name)))))
    456461        (setq implicit-dt-class (class-of (definition-type-instance implicit-type)))
    457462        (with-lock-grabbed (*source-files-lock*)
     
    485490;;; not instances
    486491(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))
     492  (do* ((specs (%method-specializers method) (%cdr specs))
     493        (args args (%cdr args))
     494        (cpls cpls (%cdr cpls)))
     495      ((null args) t)
     496    (let ((spec (%car specs))
     497          (arg (%car args)))
     498      (if (typep spec 'eql-specializer)
     499        (if (consp arg)
     500          (unless (eql (cadr arg) (eql-specializer-object spec))
     501            (return nil))
     502          (if (typep (eql-specializer-object spec) arg)
     503            ;(unless (eq arg *null-class*) (return :undecidable))
     504            t  ;; include if it's at all possible it might be applicable.
     505            (return nil)))
     506        (unless (memq spec (%car cpls))
    497507          (return nil))))))
    498508
     
    503513  (let ((gf (fboundp name)))
    504514    (when (and gf (typep gf 'standard-generic-function))
    505       (let* ((methods (%gf-methods gf))
     515      (let* ((methods (or (%gf-methods gf)
     516                          (return-from find-applicable-methods nil)))
     517             (arg-count (length (%method-specializers (car methods))))
    506518             (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))))))))))
     519             (bits (inner-lfun-bits gf))
     520             res)
     521        (unless (or (logbitp $lfbits-rest-bit bits)
     522                    (logbitp $lfbits-restv-bit bits)
     523                    (logbitp $lfbits-keys-bit bits)
     524                    (<= args-length
     525                        (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
     526                                        ;(error "Too many args for ~s" gf)
     527          (return-from find-applicable-methods))
     528        (when (< arg-count args-length)
     529          (setq args (subseq args 0 (setq args-length arg-count))))
     530        (setq args (mapcar (lambda (arg)
     531                             (typecase arg
     532                               (eql-specializer `(eql ,(eql-specializer-object arg)))
     533                               (class arg)
     534                               (symbol (or (find-class (or arg t) nil)
     535                                           ;;(error "Invalid class name ~s" arg)
     536                                           (return-from find-applicable-methods)))
     537                               (t
     538                                  (unless (and (consp arg) (eql (car arg) 'eql) (null (cddr arg)))
     539                                    ;;(error "Invalid specializer ~s" arg)
     540                                    (return-from find-applicable-methods))
     541                                  arg)))
     542                           args))
     543        (let ((cpls (make-list args-length)))
     544          (declare (dynamic-extent cpls))
     545          (do ((args-tail args (cdr args-tail))
     546               (cpls-tail cpls (cdr cpls-tail)))
     547              ((null cpls-tail))
     548            (declare (type list args-tail cpls-tail))
     549            (let ((arg (car args-tail)))
     550              (setf (car cpls-tail)
     551                    (%class-precedence-list (if (consp arg)
     552                                              (class-of (cadr arg))
     553                                              arg)))))
     554          (dolist (m methods)
     555            (when (%my-method-applicable-p m args cpls)
     556              (push m res)))
     557          (let ((methods (sort-methods res cpls (%gf-precedence-list gf))))
     558            (when (eq (generic-function-method-combination gf)
     559                      *standard-method-combination*)
     560                                        ; around* (befores) (afters) primaries*
     561              (setq methods (compute-method-list methods))
     562              (when methods
     563                (setq methods
     564                      (if (not (consp methods))
     565                        (list methods)
     566                        (let ((afters (cadr (member-if #'listp methods))))
     567                          (when afters (nremove afters methods))
     568                          (nconc
     569                           (mapcan #'(lambda (x)(if (listp x) x (cons x nil)))
     570                                   methods)
     571                           afters))))))
     572            (if (and qualifiers (neq qualifiers t))
     573              (delete-if #'(lambda (m)(not (equal qualifiers (%method-qualifiers m))))
     574                         methods)
     575              methods)))))))
    580576
    581577;;; Do this just in case record source file doesn't remember the right
     
    668664    (let (name quals specs data last)
    669665      (when (consp m)
     666        (when (eq (car m) :method) (setq m (cdr m)))
    670667        ;; (name spec1 .. specn) or (name qual1 .. qualn (spec1 ... specn))
    671668        (setq data (cdr m) last (last data))
  • branches/working-0711/ccl/lib/xref.lisp

    r12339 r12408  
    2323            XREF-ENTRY-NAME
    2424            XREF-ENTRY-TYPE
     25            XREF-ENTRY-FULL-NAME
    2526            XREF-ENTRY-METHOD-QUALIFIERS
    2627            XREF-ENTRY-METHOD-SPECIALIZERS
     
    5152                "XREF-ENTRY-NAME"
    5253                "XREF-ENTRY-TYPE"
     54                "XREF-ENTRY-FULL-NAME"
    5355                "XREF-ENTRY-METHOD-QUALIFIERS"
    5456                "XREF-ENTRY-METHOD-SPECIALIZERS"
     
    7476           "XREF-ENTRY-NAME"
    7577           "XREF-ENTRY-TYPE"
     78           "XREF-ENTRY-FULL-NAME"
    7679           "XREF-ENTRY-METHOD-QUALIFIERS"
    7780           "XREF-ENTRY-METHOD-SPECIALIZERS"
     
    206209      (cond ((eq (car form) 'setf)
    207210             (setq name form))
    208             (t (setq name (car form))
    209                (let ((last (car (last (cdr form)))))
     211            (t
     212             (when (eq (car form) :method) (pop form))
     213             (setq name (car form))
     214             (let* ((last (car (last (cdr form)))))
    210215                 (cond ((and (listp last)(or (null last)(neq (car last) 'eql)))
    211216                        (setq classes last)
     
    217222                      (setq qualifiers nil))))))
    218223     (t (setq name form)))
    219     (when (and (consp name)(eq (car name) 'setf))
    220         (setq name (or (%setf-method (cadr name)) name))) ; e.g. rplacd
     224    (when (setf-function-name-p name)
     225      (setq name (canonical-maybe-setf-name name)))
    221226    (when (not (or (symbolp name)
    222227                   (setf-function-name-p name)))
     
    245250       (equal (xref-entry-method-specializers entry1)
    246251              (xref-entry-method-specializers entry2))))
     252
     253;; XREF-ENTRY-FULL-NAME -- external
     254;;
     255(defun xref-entry-full-name (entry)
     256  (if (eql (xref-entry-type entry) 'method)
     257    `(:method ,(xref-entry-name entry)
     258              ,@(xref-entry-method-qualifiers entry)
     259              ,(xref-entry-method-specializers entry))
     260    (xref-entry-name entry)))
     261
    247262
    248263;; %DB-KEY-FROM-XREF-ENTRY -- internal
  • branches/working-0711/ccl/library/loop.lisp

    r11853 r12408  
    841841                      ;; by recognizing CL function names and nothing else.
    842842                      (if (or (symbolp (cadr x))
    843                               (and (consp (cadr x)) (eq (caadr x) 'setf)))
     843                              (ccl::setf-function-name-p  (cadr x)))
    844844                          1
    845845                          (throw 'duplicatable-code-p nil)))
Note: See TracChangeset for help on using the changeset viewer.