mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 23:32:17 -08:00
WITH-COMPILATION-UNIT is no longer needed to trap compiler conditions. Compiler now also traps internal errors and prints all errors more beautifully.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
346d06998a
commit
48024a590f
5 changed files with 187 additions and 199 deletions
|
|
@ -6,23 +6,24 @@ ECL 0.9l-p1:
|
|||
- The compiler now signals compiler-error, compiler-warning and compiler-note
|
||||
for errors, warnings and notes, respectively.
|
||||
|
||||
- WITH-COMPILATION-UNIT allows the user to set up handlers for different
|
||||
compiler conditions, including errors, warnings and simple notes. The
|
||||
recommended procedure is to use HANDLER-BIND and _NOT_ to transfer control
|
||||
out of the handler, but to defer to the default ones.
|
||||
- ECL allows the user to set up handlers for different compiler conditions,
|
||||
including errors, warnings and simple notes. The recommended procedure is to
|
||||
use HANDLER-BIND and _NOT_ to transfer control out of the compilation
|
||||
environment, but to defer to the default handlers or use the restarts ABORT
|
||||
and MUFFLE-WARNING.
|
||||
|
||||
(use-package :c)
|
||||
(let ((warnings nil))
|
||||
(with-compilation-unit ()
|
||||
(handler-bind ((compiler-error #'(lambda (c)
|
||||
(push c warnings)
|
||||
(abort)))
|
||||
(compiler-message #'(lambda (c)
|
||||
(push c warnings)
|
||||
(muffle-warning))))
|
||||
(let ((*compile-verbose* nil))
|
||||
(compile-file "foo.lsp"))))
|
||||
(let ((messages nil))
|
||||
(handler-bind ((compiler-error #'(lambda (c)
|
||||
(push c messages)
|
||||
(abort c)))
|
||||
(compiler-message #'(lambda (c)
|
||||
(push c messages)
|
||||
(muffle-warning))))
|
||||
(let ((*compile-verbose* nil))
|
||||
(compile-file "foo.lsp")))
|
||||
(format t "~&;;; Printing compiler messages")
|
||||
(loop for m in (nreverse warnings)
|
||||
(loop for m in (nreverse messages)
|
||||
for i from 0
|
||||
do (format t "~&~@<;;; ~@;Message #~D~%~A~:>" i m)))
|
||||
|
||||
|
|
|
|||
|
|
@ -259,7 +259,6 @@
|
|||
(defvar *current-form* '|compiler preprocess|)
|
||||
(defvar *compile-file-position* nil)
|
||||
(defvar *first-error* t)
|
||||
(defvar *error-p* nil)
|
||||
(defconstant *cmperr-tag* (cons nil nil))
|
||||
|
||||
(defvar *active-handlers* nil)
|
||||
|
|
|
|||
|
|
@ -19,7 +19,8 @@
|
|||
;;; included in the compiled code. The default value is OFF.
|
||||
|
||||
(defconstant +init-env-form+
|
||||
'((*compiler-phase* 't1)
|
||||
'((*compiler-in-use* t)
|
||||
(*compiler-phase* 't1)
|
||||
(*callbacks* nil)
|
||||
(*max-stack* 0)
|
||||
(*max-temp* 0)
|
||||
|
|
@ -44,7 +45,8 @@
|
|||
(*clines-string-list* '())
|
||||
(*inline-functions* nil)
|
||||
(*inline-blocks* 0)
|
||||
(*notinline* nil)))
|
||||
(*notinline* nil)
|
||||
(*debugger-hook* 'compiler-debugger)))
|
||||
|
||||
(defun next-lcl () (list 'LCL (incf *lcl*)))
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
`(progn ,@body))
|
||||
|
||||
(defun safe-system (string)
|
||||
(cmpnote "Invoking external command:~%;;; ~A" string)
|
||||
(cmpnote "Invoking external command:~% ~A" string)
|
||||
(let ((result (si:system string)))
|
||||
(unless (zerop result)
|
||||
(cerror "Continues anyway."
|
||||
|
|
@ -63,7 +63,8 @@
|
|||
(cmpprogress "~%Postponing deletion of ~A" file)
|
||||
(push file *files-to-be-deleted*))
|
||||
(t
|
||||
(delete-file file))))
|
||||
(and (probe-file file)
|
||||
(delete-file file)))))
|
||||
|
||||
(push #'(lambda () (mapc #'delete-file *files-to-be-deleted*))
|
||||
si::*exit-hooks*)
|
||||
|
|
@ -504,19 +505,10 @@ static cl_object VV[VM];
|
|||
(when (and system-p load)
|
||||
(error "Cannot load system files."))
|
||||
|
||||
(when *compiler-in-use*
|
||||
(format t "~&;;; The compiler was called recursively.~%~
|
||||
Cannot compile ~a."
|
||||
(namestring input-pathname))
|
||||
(setq *error-p* t)
|
||||
(return-from compile-file (values nil t t)))
|
||||
|
||||
(setq *error-p* nil
|
||||
*compiler-in-use* t)
|
||||
|
||||
(cmpprogress "~&;;; Compiling ~a." (namestring input-pathname))
|
||||
|
||||
(let* ((eof '(NIL))
|
||||
(*compiler-in-use* *compiler-in-use*)
|
||||
(*load-time-values* nil) ;; Load time values are compiled
|
||||
(o-pathname (or #+dlopen (and system-p output-file)
|
||||
#-dlopen output-file
|
||||
|
|
@ -527,9 +519,10 @@ Cannot compile ~a."
|
|||
(h-pathname (get-output-pathname o-pathname h-file :h))
|
||||
(data-pathname (get-output-pathname o-pathname data-file :data))
|
||||
(shared-data-pathname (get-output-pathname o-pathname shared-data-file
|
||||
:sdata)))
|
||||
:sdata))
|
||||
(compiler-conditions nil))
|
||||
|
||||
(with-compiler-env (*error-p*)
|
||||
(with-compiler-env (compiler-conditions)
|
||||
|
||||
(print-compiler-info)
|
||||
|
||||
|
|
@ -552,62 +545,50 @@ Cannot compile ~a."
|
|||
(t1expr form)
|
||||
(incf (cdr ext:*source-location*))))
|
||||
|
||||
(unless *error-p*
|
||||
(cmpprogress "~&;;; End of Pass 1.")
|
||||
(setf init-name (guess-init-name output-file :kind
|
||||
(if system-p :object :fasl)))
|
||||
(compiler-pass2 c-pathname h-pathname data-pathname system-p
|
||||
init-name
|
||||
shared-data-file))
|
||||
|
||||
(cmpprogress "~&;;; End of Pass 1.")
|
||||
(setf init-name (guess-init-name output-file :kind
|
||||
(if system-p :object :fasl)))
|
||||
(compiler-pass2 c-pathname h-pathname data-pathname system-p
|
||||
init-name
|
||||
shared-data-file)
|
||||
|
||||
(if shared-data-file
|
||||
(data-dump shared-data-pathname t)
|
||||
(data-dump data-pathname))
|
||||
|
||||
(when output-file
|
||||
(compiler-cc c-pathname o-pathname)
|
||||
#+dlopen
|
||||
(unless system-p (bundle-cc (si::coerce-to-filename so-pathname)
|
||||
init-name
|
||||
(si::coerce-to-filename o-pathname)))
|
||||
(unless (if system-p
|
||||
(probe-file o-pathname)
|
||||
(probe-file so-pathname))
|
||||
(cmperr "The C compiler failed to compile the intermediate file.")))
|
||||
(cmpprogress "~&;;; Finished compiling ~a.~%" (namestring input-pathname))
|
||||
|
||||
) ; with-compiler-env
|
||||
|
||||
(if (null *error-p*)
|
||||
(progn
|
||||
(cond (output-file
|
||||
(compiler-cc c-pathname o-pathname)
|
||||
#+dlopen
|
||||
(unless system-p (bundle-cc (si::coerce-to-filename so-pathname)
|
||||
init-name
|
||||
(si::coerce-to-filename o-pathname)))
|
||||
(cond #+dlopen
|
||||
((and (not system-p) (probe-file so-pathname))
|
||||
(when load (load so-pathname))
|
||||
(cmpprogress "~&;;; Finished compiling ~a.~%"
|
||||
(namestring input-pathname)))
|
||||
((and system-p (probe-file o-pathname))
|
||||
(cmpprogress "~&;;; Finished compiling ~a.~%"
|
||||
(namestring input-pathname)))
|
||||
(t
|
||||
(cmpprogress "~&;;; The C compiler failed to compile the intermediate file.~%")
|
||||
(setq *error-p* t))))
|
||||
(*compile-verbose*
|
||||
(cmpprogress "~&;;; Finished compiling ~a.~%"
|
||||
(namestring input-pathname))))
|
||||
(unless c-file (cmp-delete-file c-pathname))
|
||||
(unless h-file (cmp-delete-file h-pathname))
|
||||
(unless (or data-file shared-data-file)
|
||||
(cmp-delete-file data-pathname))
|
||||
#+dlopen
|
||||
(unless system-p (cmp-delete-file o-pathname))
|
||||
(values (truename #+dlopen (if system-p o-pathname so-pathname)
|
||||
#-dlopen o-pathname)
|
||||
nil nil))
|
||||
(progn
|
||||
(when (probe-file c-pathname) (cmp-delete-file c-pathname))
|
||||
(when (probe-file h-pathname) (cmp-delete-file h-pathname))
|
||||
(when (probe-file data-pathname) (cmp-delete-file data-pathname))
|
||||
(when (probe-file shared-data-pathname) (cmp-delete-file shared-data-pathname))
|
||||
(when (probe-file o-pathname) (cmp-delete-file o-pathname))
|
||||
(cmpprogress "~&;;; Due to errors in the compilation process, no FASL was generated.
|
||||
;;; Search above for the \"Error:\" tag to find the error messages.~%")
|
||||
(setq *error-p* t)
|
||||
(values nil t t))
|
||||
))
|
||||
)
|
||||
)
|
||||
(unless c-file (cmp-delete-file c-pathname))
|
||||
(unless h-file (cmp-delete-file h-pathname))
|
||||
(unless (or data-file shared-data-file)
|
||||
(cmp-delete-file data-pathname))
|
||||
#+dlopen
|
||||
(unless system-p (cmp-delete-file o-pathname))
|
||||
(compiler-output-values (truename #+dlopen (if system-p o-pathname so-pathname)
|
||||
#-dlopen o-pathname)
|
||||
compiler-conditions)))
|
||||
|
||||
(defun compiler-output-values (main-value conditions)
|
||||
(loop for i in conditions
|
||||
with warning-p = nil
|
||||
with failure-p = nil
|
||||
do (cond ((typep i 'style-warning)
|
||||
(setf warning-p t))
|
||||
((typep i '(or error warning))
|
||||
(setf warning-p t failure-p t)))
|
||||
finally (return (values (and (not failure-p) main-value) warning-p failure-p))))
|
||||
|
||||
#-dlopen
|
||||
(defun compile (name &optional (def nil supplied-p))
|
||||
|
|
@ -634,15 +615,6 @@ Cannot compile ~a."
|
|||
|
||||
(unless (symbolp name) (error "~s is not a symbol." name))
|
||||
|
||||
(when *compiler-in-use*
|
||||
(format t "~&;;; The compiler was called recursively.~
|
||||
~%Cannot compile ~s." name)
|
||||
(setq *error-p* t)
|
||||
(return-from compile (values name nil t)))
|
||||
|
||||
(setq *error-p* nil
|
||||
*compiler-in-use* t)
|
||||
|
||||
(cond ((and supplied-p def)
|
||||
(when (functionp def)
|
||||
(unless (function-lambda-expression def)
|
||||
|
|
@ -664,63 +636,63 @@ Cannot compile ~a."
|
|||
|
||||
(let ((template (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*))))
|
||||
(unless (setq data-pathname (si::mkstemp template))
|
||||
(format t "~&;;; Unable to create temporay file~%~
|
||||
;;; ~AXXXXXX
|
||||
;;; Make sure you have enough free space in disk, check permissions or set~%~
|
||||
;;; the environment variable TMPDIR to a different value." template)
|
||||
(setq *error-p* t)
|
||||
(error "Unable to create temporay file~%~
|
||||
~AXXXXXX
|
||||
Make sure you have enough free space in disk, check permissions or set~%~
|
||||
the environment variable TMPDIR to a different value." template)
|
||||
(return-from compile (values nil t t))))
|
||||
|
||||
(let*((*load-time-values* 'values) ;; Only the value is kept
|
||||
(template (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))
|
||||
(data-pathname (or (si::mkstemp template) "foo"))
|
||||
(c-pathname (compile-file-pathname data-pathname :type :c))
|
||||
(h-pathname (compile-file-pathname data-pathname :type :h))
|
||||
(o-pathname (compile-file-pathname data-pathname :type :object))
|
||||
(so-pathname (compile-file-pathname data-pathname))
|
||||
(init-name (guess-init-name so-pathname :kind :fasl)))
|
||||
(init-name (guess-init-name so-pathname :kind :fasl))
|
||||
(compiler-conditions nil))
|
||||
|
||||
(with-compiler-env (*error-p*)
|
||||
(with-compiler-env (compiler-conditions)
|
||||
(print-compiler-info)
|
||||
(data-init)
|
||||
(t1expr form)
|
||||
(unless *error-p*
|
||||
(cmpprogress "~&;;; End of Pass 1.")
|
||||
(let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t))
|
||||
(compiler-pass2 c-pathname h-pathname data-pathname nil
|
||||
init-name nil)))
|
||||
(cmpprogress "~&;;; End of Pass 1.")
|
||||
(let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t))
|
||||
(compiler-pass2 c-pathname h-pathname data-pathname nil
|
||||
init-name nil))
|
||||
(setf *compiler-constants* (data-dump data-pathname))
|
||||
|
||||
(if (null *error-p*)
|
||||
(progn
|
||||
(compiler-cc c-pathname o-pathname)
|
||||
(bundle-cc (si::coerce-to-filename so-pathname)
|
||||
init-name
|
||||
(si::coerce-to-filename o-pathname))
|
||||
(cmp-delete-file c-pathname)
|
||||
(cmp-delete-file h-pathname)
|
||||
(cmp-delete-file o-pathname)
|
||||
(cmp-delete-file data-pathname)
|
||||
(cond ((probe-file so-pathname)
|
||||
(load so-pathname :verbose nil)
|
||||
#-(or mingw32 msvc cygwin)(cmp-delete-file so-pathname)
|
||||
#+msvc (delete-msvc-generated-files so-pathname)
|
||||
(setf name (or name (symbol-value 'GAZONK)))
|
||||
;; By unsetting GAZONK we avoid spurious references to the
|
||||
;; loaded code.
|
||||
(set 'GAZONK nil)
|
||||
(si::gc t)
|
||||
(values name nil nil))
|
||||
(t (cmpprogress "~&;;; The C compiler failed to compile the intermediate code for ~s.~%" name)
|
||||
(setq *error-p* t)
|
||||
(values name t t))))
|
||||
(progn
|
||||
(when (probe-file c-pathname) (cmp-delete-file c-pathname))
|
||||
(when (probe-file h-pathname) (cmp-delete-file h-pathname))
|
||||
(when (probe-file so-pathname) (cmp-delete-file so-pathname))
|
||||
(when (probe-file data-pathname) (cmp-delete-file data-pathname))
|
||||
#+msvc (delete-msvc-generated-files so-pathname)
|
||||
(cmpprogress "~&;;; Failed to compile ~s.~%" name)
|
||||
(setq *error-p* t)
|
||||
(values name t t))))))
|
||||
(compiler-cc c-pathname o-pathname)
|
||||
(bundle-cc (si::coerce-to-filename so-pathname)
|
||||
init-name
|
||||
(si::coerce-to-filename o-pathname))
|
||||
(cmp-delete-file c-pathname)
|
||||
(cmp-delete-file h-pathname)
|
||||
(cmp-delete-file o-pathname)
|
||||
(cmp-delete-file data-pathname)
|
||||
(cond ((probe-file so-pathname)
|
||||
(load so-pathname :verbose nil)
|
||||
#-(or mingw32 msvc cygwin)
|
||||
(cmp-delete-file so-pathname)
|
||||
#+msvc
|
||||
(delete-msvc-generated-files so-pathname)
|
||||
(setf name (or name (symbol-value 'GAZONK)))
|
||||
;; By unsetting GAZONK we avoid spurious references to the
|
||||
;; loaded code.
|
||||
(set 'GAZONK nil)
|
||||
(si::gc t)
|
||||
(values name nil nil))
|
||||
(t
|
||||
(cmperr "The C compiler failed to compile the intermediate code for ~s." name)))
|
||||
) ; with-compiler-env
|
||||
|
||||
(when (probe-file c-pathname) (cmp-delete-file c-pathname))
|
||||
(when (probe-file h-pathname) (cmp-delete-file h-pathname))
|
||||
(when (probe-file so-pathname) (cmp-delete-file so-pathname))
|
||||
(when (probe-file data-pathname) (cmp-delete-file data-pathname))
|
||||
#+msvc
|
||||
(delete-msvc-generated-files so-pathname)
|
||||
(compiler-output-values name compiler-conditions)))
|
||||
|
||||
(defun disassemble (thing &key (h-file nil) (data-file nil)
|
||||
&aux def disassembled-form
|
||||
|
|
@ -749,20 +721,15 @@ Cannot compile ~a."
|
|||
:expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
|
||||
:format-control "DISASSEMBLE cannot accept ~A"
|
||||
:format-arguments (list thing))))
|
||||
(when *compiler-in-use*
|
||||
(cmpprogress "~&;;; The compiler was called recursively.~%Cannot disassemble ~a." thing)
|
||||
(setq *error-p* t)
|
||||
(return-from disassemble nil))
|
||||
(setq *error-p* nil
|
||||
*compiler-in-use* t)
|
||||
|
||||
(let* ((null-stream (make-broadcast-stream))
|
||||
(*compiler-output1* null-stream)
|
||||
(*compiler-output2* (if h-file
|
||||
(open h-file :direction :output)
|
||||
null-stream))
|
||||
(t3local-fun (symbol-function 'T3LOCAL-FUN)))
|
||||
(with-compiler-env (*error-p*)
|
||||
(t3local-fun (symbol-function 'T3LOCAL-FUN))
|
||||
(compiler-conditions nil))
|
||||
(with-compiler-env (compiler-conditions)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (symbol-function 'T3LOCAL-FUN)
|
||||
|
|
@ -771,15 +738,13 @@ Cannot compile ~a."
|
|||
(apply t3local-fun args))))
|
||||
(data-init)
|
||||
(t1expr disassembled-form)
|
||||
(unless *error-p*
|
||||
(ctop-write (guess-init-name "foo" :kind :fasl)
|
||||
(if h-file h-file "")
|
||||
(if data-file data-file "")))
|
||||
(ctop-write (guess-init-name "foo" :kind :fasl)
|
||||
(if h-file h-file "")
|
||||
(if data-file data-file ""))
|
||||
(data-dump data-file))
|
||||
(setf (symbol-function 'T3LOCAL-FUN) t3local-fun)
|
||||
(when h-file (close *compiler-output2*)))))
|
||||
nil
|
||||
)
|
||||
nil)
|
||||
|
||||
(defun compiler-pass2 (c-pathname h-pathname data-pathname system-p init-name
|
||||
shared-data)
|
||||
|
|
|
|||
|
|
@ -14,22 +14,39 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(define-condition compiler-message (condition)
|
||||
((file :initarg :file :initform *compile-file-pathname*
|
||||
(define-condition compiler-message (simple-condition)
|
||||
((prefix :initform "Note" :accessor compiler-message-prefix)
|
||||
(file :initarg :file :initform *compile-file-pathname*
|
||||
:accessor compiler-message-file)
|
||||
(position :initarg :file :initform *compile-file-position*
|
||||
:accessor compiler-message-file-position)
|
||||
(form :initarg :form :initform *current-form* :accessor compiler-message-form)))
|
||||
(form :initarg :form :initform *current-form* :accessor compiler-message-form))
|
||||
(:REPORT
|
||||
(lambda (c stream)
|
||||
(let ((position (compiler-message-file-position c)))
|
||||
(if position
|
||||
(let ((*print-length* 3)
|
||||
(*print-level* 2))
|
||||
(format stream "~A: in file ~A, position ~D, and form ~% ~A~%"
|
||||
(compiler-message-prefix c)
|
||||
(compiler-message-file c) position (compiler-message-form c)))
|
||||
(format stream "~A: " (compiler-message-prefix c)))
|
||||
(format stream "~?"
|
||||
(simple-condition-format-control c)
|
||||
(simple-condition-format-arguments c))))))
|
||||
|
||||
(define-condition compiler-note (compiler-message simple-condition warning) ())
|
||||
(define-condition compiler-note (compiler-message) ())
|
||||
|
||||
(define-condition compiler-warning (compiler-message simple-condition style-warning) ())
|
||||
(define-condition compiler-warning (compiler-message simple-condition style-warning)
|
||||
((prefix :initform "Warning")))
|
||||
|
||||
(define-condition compiler-error (compiler-message simple-error) ())
|
||||
(define-condition compiler-error (compiler-message simple-error)
|
||||
((prefix :initform "Error")))
|
||||
|
||||
(define-condition compiler-fatal-error (compiler-error) ())
|
||||
|
||||
(define-condition compiler-internal-error (compiler-fatal-error) ())
|
||||
(define-condition compiler-internal-error (compiler-fatal-error)
|
||||
((prefix :initform "Internal error")))
|
||||
|
||||
(define-condition compiler-undefined-variable (compiler-message warning)
|
||||
((variable :initarg :name :initform nil))
|
||||
|
|
@ -38,38 +55,31 @@
|
|||
(format stream "Variable ~A was undefined. Compiler assumes it is a global."
|
||||
(slot-value condition 'variable)))))
|
||||
|
||||
(defun handle-fatal-error (c)
|
||||
(push c *compiler-conditions*)
|
||||
(abort))
|
||||
|
||||
(defun print-compiler-message (c stream &optional (header "Error"))
|
||||
(let ((position (compiler-message-file-position c)))
|
||||
(if position
|
||||
(let ((*print-length* 3)
|
||||
(*print-level* 2))
|
||||
(format stream "~&;;; ~A: in file ~A, position ~D, and form ~%;;; ~A~%~@<;;; ~@;~A~:>"
|
||||
header (compiler-message-file c)
|
||||
position (compiler-message-form c) c))
|
||||
(format stream "~&~@<;;; ~@;~A: ~A~:>" header c))))
|
||||
(defun print-compiler-message (c stream)
|
||||
(format stream "~&~@<;;; ~@;~A~:>" c))
|
||||
|
||||
(defun handle-note (c)
|
||||
(unless *suppress-compiler-notes*
|
||||
(print-compiler-message c t "Note")))
|
||||
nil)
|
||||
|
||||
(defun handle-warning (c)
|
||||
(push c *compiler-conditions*)
|
||||
(unless *suppress-compiler-warnings*
|
||||
(print-compiler-message c t "Warning")))
|
||||
nil)
|
||||
|
||||
(defun handle-error (c)
|
||||
(push c *compiler-conditions*)
|
||||
(print-compiler-message c t)
|
||||
(invoke-restart (find-restart-never-fail 'abort-form c)))
|
||||
nil)
|
||||
|
||||
(defun handle-internal-error (c)
|
||||
(unless (typep c 'compiler-error)
|
||||
(signal 'compiler-internal-error
|
||||
:format-control "~A"
|
||||
:format-arguments (list c))
|
||||
(print-compiler-message c t)
|
||||
(abort)))
|
||||
|
||||
(defun do-compilation-unit (closure &key override)
|
||||
(cond (override
|
||||
(let* ((*active-handlers* nil)
|
||||
(*active-protection* nil))
|
||||
(let* ((*active-protection* nil))
|
||||
(do-compilation-unit closure)))
|
||||
((null *active-protection*)
|
||||
(let* ((*active-protection* t)
|
||||
|
|
@ -77,27 +87,33 @@
|
|||
(unwind-protect (do-compilation-unit closure)
|
||||
(loop for action in *pending-actions*
|
||||
do (funcall action)))))
|
||||
((null *active-handlers*)
|
||||
(let ((*active-handlers* t))
|
||||
(handler-bind ((compiler-note #'handle-note)
|
||||
(compiler-warning #'handle-warning)
|
||||
(compiler-error #'handle-error)
|
||||
(compiler-fatal-error #'handle-fatal-error))
|
||||
(funcall closure))))
|
||||
(t
|
||||
(funcall closure))))
|
||||
|
||||
(defmacro with-compilation-unit ((&rest options) &body body)
|
||||
`(do-compilation-unit #'(lambda () ,@body) ,@options))
|
||||
|
||||
(defmacro with-compiler-env ((error-flag) &body body)
|
||||
`(with-lock (+load-compile-lock+)
|
||||
(defun compiler-debugger (condition old-hook)
|
||||
(when *compiler-break-enable*
|
||||
(si::default-debugger condition))
|
||||
(abort))
|
||||
|
||||
(defmacro with-compiler-env ((compiler-conditions) &body body)
|
||||
`(let ((*compiler-conditions* nil))
|
||||
(declare (special *compiler-conditions*))
|
||||
(restart-case
|
||||
(let ,+init-env-form+
|
||||
(setf ,error-flag nil)
|
||||
(with-compilation-unit ()
|
||||
,@body))
|
||||
(abort (c) (setf ,error-flag t)))))
|
||||
(handler-bind ((compiler-note #'handle-note)
|
||||
(warning #'handle-warning)
|
||||
(compiler-error #'handle-error))
|
||||
(handler-bind ((error #'handle-internal-error))
|
||||
(if *compiler-in-use*
|
||||
(error "The compiler was called recursively.")
|
||||
(with-lock (+load-compile-lock+)
|
||||
(let ,+init-env-form+
|
||||
(with-compilation-unit ()
|
||||
,@body))))))
|
||||
(abort ()))
|
||||
(setf ,compiler-conditions *compiler-conditions*)))
|
||||
|
||||
(defvar *c1form-level* 0)
|
||||
(defun print-c1forms (form)
|
||||
|
|
@ -126,7 +142,9 @@
|
|||
(defun cmperr (string &rest args)
|
||||
(signal 'compiler-error
|
||||
:format-control string
|
||||
:format-arguments args))
|
||||
:format-arguments args)
|
||||
(print-compiler-message c t)
|
||||
(abort))
|
||||
|
||||
(defun check-args-number (operator args &optional (min 0) (max nil))
|
||||
(let ((l (length args)))
|
||||
|
|
@ -147,21 +165,23 @@
|
|||
lower-bound
|
||||
n))
|
||||
|
||||
(defun do-cmpwarn (&rest args)
|
||||
(defun do-cmpwarn (suppress &rest args)
|
||||
(declare (si::c-local))
|
||||
(let ((condition (apply #'make-condition args)))
|
||||
(restart-case (signal condition)
|
||||
(muffle-warning ()
|
||||
:REPORT "Skip warning"
|
||||
(return-from do-cmpwarn nil)))))
|
||||
(return-from do-cmpwarn nil)))
|
||||
(unless suppress
|
||||
(print-compiler-message condition t))))
|
||||
|
||||
(defun cmpwarn (string &rest args)
|
||||
(do-cmpwarn 'compiler-warning
|
||||
(do-cmpwarn *suppress-compiler-warnings* 'compiler-warning
|
||||
:format-control string
|
||||
:format-arguments args))
|
||||
|
||||
(defun cmpnote (string &rest args)
|
||||
(do-cmpwarn 'compiler-note
|
||||
(do-cmpwarn *suppress-compiler-notes* 'compiler-note
|
||||
:format-control string
|
||||
:format-arguments args))
|
||||
|
||||
|
|
@ -180,7 +200,8 @@
|
|||
(format t "~&;;; Emitting code for ~s.~%" name))))
|
||||
|
||||
(defun undefined-variable (sym)
|
||||
(do-cmpwarn 'compiler-undefined-variable :name sym))
|
||||
(do-cmpwarn *suppress-compiler-warnings*
|
||||
'compiler-undefined-variable :name sym))
|
||||
|
||||
(defun baboon (&aux (*print-case* :upcase))
|
||||
(signal 'compiler-internal-error
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue