Changeset 12463 for trunk/source/level-1


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/level-1
Files:
10 edited

Legend:

Unmodified
Added
Removed
  • 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
Note: See TracChangeset for help on using the changeset viewer.