Changeset 12463


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)

Location:
trunk/source
Files:
22 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx-basic.lisp

    r12411 r12463  
    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                      (setf (compiler-warning-nrefs w1)
    548556                            (cons (compiler-warning-source-note w)
    549557                                  (or nrefs
    550                                       (list (compiler-warning-source-note w1))))))
    551                     (return)))))
     558                                      (list (compiler-warning-source-note w1)))))
     559                      (return nil))))))
    552560          (push w warnings))))
    553561    warnings))
     
    644652
    645653
    646 (defun report-compiler-warning (condition stream)
     654(defun report-compiler-warning (condition stream &key short)
    647655  (let* ((warning-type (compiler-warning-warning-type condition))
    648656         (format-string (cdr (assq warning-type *compiler-warning-formats*)))
    649          (name (reverse (compiler-warning-function-name condition))))
    650     (format stream "In ")
    651     (print-nested-name name stream)
    652     (when (every #'null name)
    653       (let ((position (compiler-warning-stream-position condition)))
    654         (when position (format stream " at position ~s" position))))
    655     (format stream ": ")
     657         (warning-args (compiler-warning-args condition)))
     658    (unless short
     659      (let ((name (reverse (compiler-warning-function-name condition))))
     660        (format stream "In ")
     661        (print-nested-name name stream)
     662        (when (every #'null name)
     663          (let ((position (source-note-start-pos (compiler-warning-source-note condition))))
     664            (when position (format stream " at position ~s" position))))
     665        (format stream ": ")))
    656666    (if (typep format-string 'string)
    657       (apply #'format stream format-string (adjust-compiler-warning-args warning-type (compiler-warning-args condition)))
     667      (apply #'format stream format-string (adjust-compiler-warning-args warning-type warning-args))
    658668      (if (null format-string)
    659         (format stream "~A: ~S" warning-type (compiler-warning-args condition))
     669        (format stream "~A: ~S" warning-type warning-args)
    660670        (funcall format-string condition stream)))
    661671    ;(format stream ".")
  • trunk/source/level-1/l1-aprims.lisp

    r12371 r12463  
    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))
  • trunk/source/level-1/l1-clos-boot.lisp

    r12219 r12463  
    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))))))
  • trunk/source/level-1/l1-error-system.lisp

    r12221 r12463  
    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)
  • trunk/source/level-1/l1-events.lisp

    r12222 r12463  
    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 ()
  • trunk/source/level-1/l1-lisp-threads.lisp

    r12219 r12463  
    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
  • trunk/source/level-1/l1-readloop-lds.lisp

    r12403 r12463  
    474474  (#__exit -1))
    475475
    476 (defun break-loop-handle-error (condition error-pointer)
     476(defvar *top-error-frame* nil)
     477
     478(defun break-loop-handle-error (condition *top-error-frame*)
    477479  (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals)
    478480    (dolist (x bogus-globals)
     
    482484            (*debugger-hook* nil))
    483485        (funcall hook condition hook)))
    484     (%break-message "Error" condition error-pointer)
     486    (%break-message "Error" condition)
    485487    (let* ((s *error-output*))
    486488      (dolist (bogusness bogus-globals)
     
    492494          (format s ", was reset to ~s ." (symbol-value bogusness)))))
    493495    (if (and *break-on-errors* (not *batch-flag*))
    494       (break-loop condition error-pointer)
     496      (break-loop condition)
    495497      (if *batch-flag*
    496498        (abnormal-application-exit)
     
    525527
    526528
    527 (defun invoke-debugger (condition &aux (fp (%get-frame-ptr)))
     529(defun invoke-debugger (condition &aux (*top-error-frame* (%get-frame-ptr)))
    528530  "Enter the debugger."
    529531  (let ((c (require-type condition 'condition)))
     
    532534            (*debugger-hook* nil))
    533535        (funcall hook c hook)))
    534     (%break-message "Debug" c fp)
    535     (break-loop c fp)))
    536 
    537 (defun %break-message (msg condition error-pointer &optional (prefixchar #\>))
     536    (%break-message "Debug" c)
     537    (break-loop c)))
     538
     539(defun %break-message (msg condition &optional (error-pointer *top-error-frame*) (prefixchar #\>))
    538540  (let ((*print-circle* *error-print-circle*)
    539541        ;(*print-prett*y nil)
     
    565567(defvar *break-hook* nil)
    566568
    567 (defun cbreak-loop (msg cont-string condition error-pointer)
     569(defun cbreak-loop (msg cont-string condition *top-error-frame*)
    568570  (let* ((*print-readably* nil)
    569571         (hook *break-hook*))
     
    573575                        (funcall hook condition hook))
    574576                      (setq hook nil))
    575                     (%break-message msg condition error-pointer)
    576                     (break-loop condition error-pointer))
     577                    (%break-message msg condition)
     578                    (when (and (eq (type-of condition) 'simple-condition)
     579                               (equal (simple-condition-format-control condition) ""))
     580                      (setq condition (make-condition 'simple-condition
     581                                        :format-control "~a"
     582                                        :format-arguments (list msg))))
     583                    (break-loop condition))
    577584      (continue () :report (lambda (stream) (write-string cont-string stream))))
    578585    (unless hook
     
    631638
    632639(defvar %last-continue% nil)
    633 (defun break-loop (condition frame-pointer)
     640(defun break-loop (condition &optional (frame-pointer *top-error-frame*))
    634641  "Never returns"
    635642  (let* ((%handlers% (last %handlers%)) ; firewall
  • trunk/source/level-1/l1-readloop.lisp

    r12205 r12463  
    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)
  • trunk/source/level-1/l1-sockets.lisp

    r12267 r12463  
    896896                (set-socket-fd-blocking fd was-blocking)))))))
    897897
    898 (defun accept-socket-connection (socket wait stream-create-function)
     898(defun accept-socket-connection (socket wait stream-create-function &optional stream-args)
    899899  (let ((listen-fd (socket-device socket))
    900900        (fd -1))
    901901    (unwind-protect
    902       (progn
     902      (let ((keys (append stream-args (socket-keys socket))))
    903903        (setq fd (socket-accept listen-fd wait))
    904904        (cond ((>= fd 0)
    905                (prog1 (apply stream-create-function fd (socket-keys socket))
     905               (prog1 (apply stream-create-function fd keys)
    906906                 (setq fd -1)))
    907907              ((eql fd (- #$EAGAIN)) nil)
     
    910910        (fd-close fd)))))
    911911
    912 (defgeneric accept-connection (socket &key wait)
     912(defgeneric accept-connection (socket &key wait stream-args)
    913913  (:documentation
    914914  "Extract the first connection on the queue of pending connections,
     
    916916tcp-stream or file-socket-stream representing the newly established
    917917connection.  The tcp stream inherits any properties of the listener socket
    918 that are relevant (e.g. :keepalive, :nodelay, etc.) The original listener
     918that are relevant (e.g. :keepalive, :nodelay, etc.) Additional arguments
     919may be specified using STREAM-ARGS. The original listener
    919920socket continues to be open listening for more connections, so you can call
    920921accept-connection on it again."))
    921922
    922 (defmethod accept-connection ((socket listener-socket) &key (wait t))
    923   (accept-socket-connection socket wait #'make-tcp-stream))
    924 
    925 (defmethod accept-connection ((socket file-listener-socket) &key (wait t))
    926   (accept-socket-connection socket wait #'make-file-socket-stream))
     923(defmethod accept-connection ((socket listener-socket) &key (wait t) stream-args)
     924  (accept-socket-connection socket wait #'make-tcp-stream stream-args))
     925
     926(defmethod accept-connection ((socket file-listener-socket) &key (wait t) stream-args)
     927  (accept-socket-connection socket wait #'make-file-socket-stream stream-args))
    927928
    928929(defun verify-socket-buffer (buf offset size)
  • trunk/source/level-1/linux-files.lisp

    r12450 r12463  
    192192        (when (eql 0 (%get-byte buf i))
    193193          (return i))))))
    194    
    195    
     194
     195(defun temp-pathname ()
     196  "Return a suitable pathname for a temporary file.  A different name is returned
     197each time this is called in a session.  No file by that name existed when last
     198checked, though no guarantee is given that one hasn't been created since."
     199  (native-to-pathname
     200     #-windows-target (get-foreign-namestring (#_tmpnam (%null-ptr)))
     201     #+windows-target (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
     202                        (#_GetTempPathW #$MAX_PATH buffer)
     203                        (with-filename-cstrs ((c-prefix "ccl"))
     204                            (#_GetTempFileNameW buffer c-prefix 0 buffer)
     205                              (#_DeleteFileW buffer)
     206                                (%get-native-utf-16-cstring buffer)))))
     207
    196208(defun current-directory-name ()
    197209  "Look up the current working directory of the OpenMCL process; unless
  • trunk/source/level-1/sysutils.lisp

    r12371 r12463  
    581581                    (lambda (c)
    582582                      (let ((w2 (make-condition 'invalid-type-warning
    583                                   :file-name (compiler-warning-file-name w)
    584583                                  :function-name (compiler-warning-function-name w)
    585584                                  :source-note (compiler-warning-source-note w)
    586585                                  :warning-type :invalid-type
    587586                                  :args (list typespec c))))
    588                         (setf (compiler-warning-stream-position w2)
    589                               (compiler-warning-stream-position w))
    590587                        (return-from verify-deferred-type-warning w2)))))
    591588      (values-specifier-type typespec)
     
    613610                   (let* ((w2 (make-condition
    614611                               'invalid-arguments
    615                                :file-name (compiler-warning-file-name w)
    616612                               :function-name (compiler-warning-function-name w)
    617613                               :source-note (compiler-warning-source-note w)
    618614                               :warning-type deftype
    619615                               :args (list (car args) reason arglist spread-p))))
    620                      (setf (compiler-warning-stream-position w2)
    621                            (compiler-warning-stream-position w))
    622616                     w2))))))
    623617          ((def-info.macro-p (cdr def))
    624618           (let* ((w2 (make-condition
    625619                       'macro-used-before-definition
    626                        :file-name (compiler-warning-file-name w)
    627620                       :function-name (compiler-warning-function-name w)
    628621                       :source-note (compiler-warning-source-note w)
    629622                       :warning-type :macro-used-before-definition
    630623                       :args (list (car args)))))
    631              (setf (compiler-warning-stream-position w2)
    632                    (compiler-warning-stream-position w))
    633624             w2)))))
    634625
  • trunk/source/lib/backtrace-lds.lisp

    r10114 r12463  
    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
  • trunk/source/lib/backtrace.lisp

    r12193 r12463  
    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)
  • trunk/source/lib/ccl-export-syms.lisp

    r12368 r12463  
    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
     
    283305     directory-pathname-p
    284306     full-pathname
     307     temp-pathname
    285308     create-file
    286309     create-directory
     
    305328     with-filename-cstrs
    306329     get-foreign-namestring
     330     native-translated-namestring
     331     native-to-pathname
    307332     fasl-concatenate
    308333     event-ticks
     
    426451     *trace-max-indent*
    427452     *trace-level*
    428      *fasl-save-doc-strings*
    429      *fasl-save-definitions*
    430453     *static-cons-chunk*
    431454     static-cons
     
    435458     population-type
    436459     population-contents
     460
     461     hash-table-weak-p
    437462
    438463     compiler-let
     
    463488     make-process
    464489     process-suspend-count
     490     process-serial-number
    465491     process-initial-form
    466492     process-whostate
     
    471497     process-resume
    472498     process-suspend
     499     process-exhausted-p
    473500     let-globally
    474501     process-wait
     
    741768   "METHOD-SPECIALIZERS"
    742769   "METHOD-QUALIFIERS"
     770   "SLOT-DEFINITION-DOCUMENTATION"
    743771   "SLOT-DEFINITION-ALLOCATION"
    744772   "SLOT-DEFINITION-INITARGS"
     
    825853   "ENSURE-CLASS-USING-CLASS"
    826854   "ENSURE-GENERIC-FUNCTION-USING-CLASS"
     855   "EQL-SPECIALIZER"
    827856   "EQL-SPECIALIZER-OBJECT"
    828857   "EXTRACT-LAMBDA-LIST"
     
    847876   "METHOD-SPECIALIZERS"
    848877   "METHOD-QUALIFIERS"
     878   "SLOT-DEFINITION-DOCUMENTATION"
    849879   "SLOT-DEFINITION-ALLOCATION"
    850880   "SLOT-DEFINITION-INITARGS"
  • trunk/source/lib/describe.lisp

    r11740 r12463  
    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")
  • trunk/source/lib/edit-callers.lisp

    r12195 r12463  
    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
  • trunk/source/lib/encapsulate.lisp

    r12194 r12463  
    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
  • trunk/source/lib/macros.lisp

    r12429 r12463  
    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)))
  • trunk/source/lib/nfcomp.lisp

    r12411 r12463  
    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)
     
    10701072        (harsh *fasl-non-style-warnings-signalled-p*))
    10711073    (dolist (w warnings)
    1072       (setf (compiler-warning-file-name w) *fasl-source-file*)
    1073       (setf (compiler-warning-stream-position w) *fcomp-stream-position*)
     1074      (unless (compiler-warning-source-note w)
     1075        (setf (compiler-warning-source-note w)
     1076              (make-source-note :source nil
     1077                                :filename *fasl-source-file*
     1078                                :start-pos *fcomp-stream-position*
     1079                                :end-pos *fcomp-stream-position*)))
    10741080      (if (and (typep w 'undefined-reference)
    10751081               (eq w (setq w (macro-too-late-p w env))))
     
    10951101                     (eq 'macro (cadr info)))))
    10961102          (make-instance 'macro-used-before-definition
    1097             :file-name (compiler-warning-file-name w)
     1103            :source-note (compiler-warning-source-note w)
    10981104            :function-name (compiler-warning-function-name w)
    10991105            :warning-type ':macro-used-before-definition
  • 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))
  • trunk/source/lib/xref.lisp

    r12327 r12463  
    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
  • trunk/source/library/loop.lisp

    r12219 r12463  
    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.