/[slime]/slime/swank-lispworks.lisp
ViewVC logotype

Diff of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.69 by mbaringer, Tue Apr 5 13:45:32 2005 UTC revision 1.70 by eweitz, Wed May 4 08:39:14 2005 UTC
# Line 370  Return NIL if the symbol is unbound." Line 370  Return NIL if the symbol is unbound."
370    (with-swank-compilation-unit (filename)    (with-swank-compilation-unit (filename)
371      (compile-file filename :load load-p)))      (compile-file filename :load load-p)))
372    
373    (defvar *within-call-with-compilation-hooks* nil
374      "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
375    
376    (defvar *undefined-functions-hash* nil
377      "Hash table to map info about undefined functions to pathnames.")
378    
379    (lw:defadvice (compile-file compile-file-and-collect-notes :around)
380        (pathname &rest rest)
381      (prog1 (apply #'lw:call-next-advice pathname rest)
382        (when *within-call-with-compilation-hooks*
383          (maphash (lambda (unfun dspecs)
384                     (dolist (dspec dspecs)
385                       (let ((unfun-info (list unfun dspec)))
386                         (unless (gethash unfun-info *undefined-functions-hash*)
387                           (setf (gethash unfun-info *undefined-functions-hash*)
388                                   pathname)))))
389                   compiler::*unknown-functions*))))
390    
391  (defimplementation call-with-compilation-hooks (function)  (defimplementation call-with-compilation-hooks (function)
392    ;; #'pray instead of #'handler-bind    (let ((compiler::*error-database* '())
393    (funcall function))          (*undefined-functions-hash* (make-hash-table :test 'equal))
394            (*within-call-with-compilation-hooks* t))
395        (with-compilation-unit ()
396          (prog1 (funcall function)
397            (signal-error-data-base compiler::*error-database*)
398            (signal-undefined-functions compiler::*unknown-functions*)))))
399    
400  (defun map-error-database (database fn)  (defun map-error-database (database fn)
401    (loop for (filename . defs) in database do    (loop for (filename . defs) in database do
# Line 496  Return NIL if the symbol is unbound." Line 519  Return NIL if the symbol is unbound."
519         nil)         nil)
520       location)))       location)))
521    
522  (defun signal-error-data-base (database location)  (defun signal-error-data-base (database &optional location)
523    (map-error-database    (map-error-database
524     database     database
525     (lambda (filename dspec condition)     (lambda (filename dspec condition)
      (declare (ignore filename))  
526       (signal-compiler-condition       (signal-compiler-condition
527        (format nil "~A" condition)        (format nil "~A" condition)
528        (make-dspec-progenitor-location dspec location)        (make-dspec-progenitor-location dspec (or location filename))
529        condition))))        condition))))
530    
531  (defun signal-undefined-functions (htab filename)  (defun signal-undefined-functions (htab &optional filename)
532    (maphash (lambda (unfun dspecs)    (maphash (lambda (unfun dspecs)
533               (dolist (dspec dspecs)               (dolist (dspec dspecs)
534                 (signal-compiler-condition                 (signal-compiler-condition
535                  (format nil "Undefined function ~A" unfun)                  (format nil "Undefined function ~A" unfun)
536                  (make-dspec-progenitor-location dspec filename)                  (make-dspec-progenitor-location dspec
537                                                    (or filename
538                                                        (gethash (list unfun dspec)
539                                                                 *undefined-functions-hash*)))
540                  nil)))                  nil)))
541             htab))             htab))
542    

Legend:
Removed from v.1.69  
changed lines
  Added in v.1.70

  ViewVC Help
Powered by ViewVC 1.1.5