mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-17 06:42:18 -08:00
Implemented compiler conditions
This commit is contained in:
Juan Jose Garcia Ripoll
parent
9aef7cea75
commit
edb7390a0f
8 changed files with 233 additions and 204 deletions
|
|
@ -1,6 +1,11 @@
|
|||
ECL 0.9l-p1:
|
||||
============
|
||||
|
||||
* Visible changes:
|
||||
|
||||
- The compiler now signals compiler-error, compiler-warning and compiler-note
|
||||
for errors, warnings and notes, respectively.
|
||||
|
||||
* Bugs fixed:
|
||||
|
||||
- The optimizer for COERCE might enter an infinite loop for certain
|
||||
|
|
|
|||
|
|
@ -247,11 +247,14 @@
|
|||
;;; Variables and constants for error handling
|
||||
;;;
|
||||
(defvar *current-form* '|compiler preprocess|)
|
||||
(defvar *compile-file-position* nil)
|
||||
(defvar *first-error* t)
|
||||
(defvar *error-count* 0)
|
||||
(defvar *error-p* nil)
|
||||
(defconstant *cmperr-tag* (cons nil nil))
|
||||
|
||||
(defvar *compiler-conditions* '()
|
||||
"This variable determines whether conditions are printed or just accumulated.")
|
||||
|
||||
(defvar *compile-print* t
|
||||
"This variable controls whether the compiler displays messages about
|
||||
each form it processes. The default value is NIL.")
|
||||
|
|
@ -324,6 +327,8 @@ The default value is NIL.")
|
|||
(defvar *next-cmacro* 0) ; holds the last cmacro number used.
|
||||
(defvar *next-cfun* 0) ; holds the last cfun used.
|
||||
|
||||
(defvar *max-stack* 0) ; maximum space used in lisp stack
|
||||
|
||||
;;;
|
||||
;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
|
||||
;;; If possible, *tail-recursion-info* holds
|
||||
|
|
|
|||
|
|
@ -18,35 +18,33 @@
|
|||
;;; If (safe-compile) is ON, some kind of run-time checks are not
|
||||
;;; included in the compiled code. The default value is OFF.
|
||||
|
||||
(defun init-env ()
|
||||
(setq *compiler-phase* 't1)
|
||||
(setq *callbacks* nil)
|
||||
(setq *max-stack* 0)
|
||||
(setq *max-temp* 0)
|
||||
(setq *temp* 0)
|
||||
(setq *next-cmacro* 0)
|
||||
(setq *next-cfun* 0)
|
||||
(setq *last-label* 0)
|
||||
(setq *load-objects* (make-hash-table :size 128 :test #'equal))
|
||||
(setq *make-forms* nil)
|
||||
(setq *permanent-objects* nil)
|
||||
(setq *temporary-objects* nil)
|
||||
(setq *local-funs* nil)
|
||||
(setq *global-var-objects* nil)
|
||||
(setq *global-vars* nil)
|
||||
(setq *global-funs* nil)
|
||||
(setq *linking-calls* nil)
|
||||
(setq *global-entries* nil)
|
||||
(setq *undefined-vars* nil)
|
||||
(setq *reservations* nil)
|
||||
(setq *top-level-forms* nil)
|
||||
(setq *compile-time-too* nil)
|
||||
(setq *clines-string-list* '())
|
||||
(setq *function-declarations* nil)
|
||||
(setq *inline-functions* nil)
|
||||
(setq *inline-blocks* 0)
|
||||
(setq *notinline* nil)
|
||||
)
|
||||
(defconstant +init-env-form+
|
||||
'((*compiler-phase* 't1)
|
||||
(*callbacks* nil)
|
||||
(*max-stack* 0)
|
||||
(*max-temp* 0)
|
||||
(*temp* 0)
|
||||
(*next-cmacro* 0)
|
||||
(*next-cfun* 0)
|
||||
(*last-label* 0)
|
||||
(*load-objects* (make-hash-table :size 128 :test #'equal))
|
||||
(*make-forms* nil)
|
||||
(*permanent-objects* nil)
|
||||
(*temporary-objects* nil)
|
||||
(*local-funs* nil)
|
||||
(*global-var-objects* nil)
|
||||
(*global-vars* nil)
|
||||
(*global-funs* nil)
|
||||
(*linking-calls* nil)
|
||||
(*global-entries* nil)
|
||||
(*undefined-vars* nil)
|
||||
(*reservations* nil)
|
||||
(*top-level-forms* nil)
|
||||
(*compile-time-too* nil)
|
||||
(*clines-string-list* '())
|
||||
(*inline-functions* nil)
|
||||
(*inline-blocks* 0)
|
||||
(*notinline* nil)))
|
||||
|
||||
(defun next-lcl () (list 'LCL (incf *lcl*)))
|
||||
|
||||
|
|
|
|||
|
|
@ -297,7 +297,7 @@
|
|||
:args used-vars (nreverse used-forms) body))
|
||||
(let* ((var (first vs))
|
||||
(form (and-form-type (var-type var) (car fs) (cadar args)
|
||||
:unsafe "~&;;; In LET* body"))
|
||||
:unsafe "In LET* body"))
|
||||
(form-type (c1form-primary-type form))
|
||||
(rest-forms (cons body (rest fs))))
|
||||
;; Automatic treatement for READ-ONLY variables:
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@
|
|||
(defun cmp-delete-file (file)
|
||||
(cond ((null *delete-files*))
|
||||
(*debug-compiler*
|
||||
(format t "~%Postponing deletion of ~A" file)
|
||||
(cmpprogress "~%Postponing deletion of ~A" file)
|
||||
(push file *files-to-be-deleted*))
|
||||
(t
|
||||
(delete-file file))))
|
||||
|
|
@ -471,7 +471,6 @@ static cl_object VV[VM];
|
|||
(*compiler-in-use* *compiler-in-use*)
|
||||
(*package* *package*)
|
||||
(*print-pretty* nil)
|
||||
(*error-count* 0)
|
||||
(*compile-file-pathname* nil)
|
||||
(*compile-file-truename* nil)
|
||||
(*compile-verbose* verbose)
|
||||
|
|
@ -515,9 +514,7 @@ Cannot compile ~a."
|
|||
(setq *error-p* nil
|
||||
*compiler-in-use* t)
|
||||
|
||||
(when *compile-verbose*
|
||||
(format t "~&;;; Compiling ~a."
|
||||
(namestring input-pathname)))
|
||||
(cmpprogress "~&;;; Compiling ~a." (namestring input-pathname))
|
||||
|
||||
(let* ((eof '(NIL))
|
||||
(*load-time-values* nil) ;; Load time values are compiled
|
||||
|
|
@ -532,8 +529,9 @@ Cannot compile ~a."
|
|||
(shared-data-pathname (get-output-pathname o-pathname shared-data-file
|
||||
:sdata)))
|
||||
|
||||
(with-lock (+load-compile-lock+)
|
||||
(init-env)
|
||||
(with-compiler-env (*error-p*)
|
||||
|
||||
(print-compiler-info)
|
||||
|
||||
(when (probe-file "./cmpinit.lsp")
|
||||
(load "./cmpinit.lsp" :verbose *compile-verbose*))
|
||||
|
|
@ -548,13 +546,14 @@ Cannot compile ~a."
|
|||
(with-open-file (*compiler-input* *compile-file-pathname*)
|
||||
(do ((ext:*source-location* (cons *compile-file-pathname* 0))
|
||||
(form (read *compiler-input* nil eof)
|
||||
(read *compiler-input* nil eof)))
|
||||
(read *compiler-input* nil eof))
|
||||
(*compile-file-position* 0 (1+ *compile-file-position*)))
|
||||
((eq form eof))
|
||||
(t1expr form)
|
||||
(incf (cdr ext:*source-location*))))
|
||||
|
||||
(when (zerop *error-count*)
|
||||
(when *compile-verbose* (format t "~&;;; End of Pass 1. "))
|
||||
(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
|
||||
|
|
@ -565,58 +564,50 @@ Cannot compile ~a."
|
|||
(data-dump shared-data-pathname t)
|
||||
(data-dump data-pathname))
|
||||
|
||||
(init-env)
|
||||
);; with-lock
|
||||
|
||||
(if (zerop *error-count*)
|
||||
(progn
|
||||
(cond (output-file
|
||||
(when *compile-verbose*
|
||||
(format t "~&;;; Calling the C compiler... "))
|
||||
(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))
|
||||
(when *compile-verbose*
|
||||
(print-compiler-info)
|
||||
(format t "~&;;; Finished compiling ~a.~%"
|
||||
(namestring input-pathname))))
|
||||
((and system-p (probe-file o-pathname))
|
||||
(when *compile-verbose*
|
||||
(print-compiler-info)
|
||||
(format t "~&;;; Finished compiling ~a.~%"
|
||||
(namestring input-pathname))))
|
||||
(t (format t "~&;;; The C compiler failed to compile the intermediate file.~%")
|
||||
(setq *error-p* t))))
|
||||
(*compile-verbose*
|
||||
(print-compiler-info)
|
||||
(format t "~&;;; 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))
|
||||
(format t "~&;;; Due to errors in the compilation process, no FASL was generated.
|
||||
(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))
|
||||
))
|
||||
)
|
||||
(setq *error-p* t)
|
||||
(values nil t t))
|
||||
))
|
||||
)
|
||||
)
|
||||
|
||||
#-dlopen
|
||||
(defun compile (name &optional (def nil supplied-p))
|
||||
|
|
@ -639,8 +630,7 @@ Cannot compile ~a."
|
|||
(*package* *package*)
|
||||
(*compile-print* nil)
|
||||
(*print-pretty* nil)
|
||||
(*compiler-constants* t)
|
||||
(*error-count* 0))
|
||||
(*compiler-constants* t))
|
||||
|
||||
(unless (symbolp name) (error "~s is not a symbol." name))
|
||||
|
||||
|
|
@ -688,55 +678,49 @@ Cannot compile ~a."
|
|||
(so-pathname (compile-file-pathname data-pathname))
|
||||
(init-name (guess-init-name so-pathname :kind :fasl)))
|
||||
|
||||
(with-lock (+load-compile-lock+)
|
||||
(init-env)
|
||||
(with-compiler-env (*error-p*)
|
||||
(print-compiler-info)
|
||||
(data-init)
|
||||
(t1expr form)
|
||||
(when (zerop *error-count*)
|
||||
(when *compile-verbose* (format t "~&;;; End of Pass 1. "))
|
||||
(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)))
|
||||
(setf *compiler-constants* (data-dump data-pathname))
|
||||
(init-env)
|
||||
)
|
||||
|
||||
(if (zerop *error-count*)
|
||||
(progn
|
||||
(when *compile-verbose*
|
||||
(format t "~&;;; Calling the C compiler... "))
|
||||
(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)
|
||||
(when *compile-verbose* (print-compiler-info))
|
||||
(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 (format t "~&;;; 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)
|
||||
(format t "~&;;; Failed to compile ~s.~%" name)
|
||||
(setq *error-p* t)
|
||||
(values name t t)))))
|
||||
(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))))))
|
||||
|
||||
(defun disassemble (thing &key (h-file nil) (data-file nil)
|
||||
&aux def disassembled-form
|
||||
|
|
@ -766,8 +750,7 @@ Cannot compile ~a."
|
|||
:format-control "DISASSEMBLE cannot accept ~A"
|
||||
:format-arguments (list thing))))
|
||||
(when *compiler-in-use*
|
||||
(format t "~&;;; The compiler was called recursively.~
|
||||
~%Cannot disassemble ~a." thing)
|
||||
(cmpprogress "~&;;; The compiler was called recursively.~%Cannot disassemble ~a." thing)
|
||||
(setq *error-p* t)
|
||||
(return-from disassemble nil))
|
||||
(setq *error-p* nil
|
||||
|
|
@ -778,27 +761,21 @@ Cannot compile ~a."
|
|||
(*compiler-output2* (if h-file
|
||||
(open h-file :direction :output)
|
||||
null-stream))
|
||||
(*error-count* 0)
|
||||
(t3local-fun (symbol-function 'T3LOCAL-FUN)))
|
||||
(with-lock (+load-compile-lock+)
|
||||
(with-compiler-env (*error-p*)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (symbol-function 'T3LOCAL-FUN)
|
||||
#'(lambda (&rest args)
|
||||
(let ((*compiler-output1* *standard-output*))
|
||||
(apply t3local-fun args))))
|
||||
(init-env)
|
||||
(data-init)
|
||||
(t1expr disassembled-form)
|
||||
(if (zerop *error-count*)
|
||||
(catch *cmperr-tag*
|
||||
(ctop-write (guess-init-name "foo" :kind :fasl)
|
||||
(if h-file h-file "")
|
||||
(if data-file data-file "")))
|
||||
(setq *error-p* t))
|
||||
(data-dump data-file)
|
||||
(init-env)
|
||||
)
|
||||
(unless *error-p*
|
||||
(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
|
||||
|
|
@ -856,8 +833,8 @@ Cannot compile ~a."
|
|||
))
|
||||
|
||||
(defun print-compiler-info ()
|
||||
(format t "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%"
|
||||
*safety* *space* *speed* *debug*))
|
||||
(cmpprogress "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%"
|
||||
*safety* *space* *speed* *debug*))
|
||||
|
||||
(defmacro with-compilation-unit (options &rest body)
|
||||
`(progn ,@body))
|
||||
|
|
|
|||
|
|
@ -189,7 +189,7 @@
|
|||
;;; form.
|
||||
;;;
|
||||
(defparameter +coercion-table+
|
||||
'((integer . (check-type x 'integer))
|
||||
'((integer . (let ((y x)) (check-type y integer) x))
|
||||
(float . (float x))
|
||||
(short-float . (float x 0.0s0))
|
||||
(single-float . (float x 0.0f0))
|
||||
|
|
@ -305,5 +305,3 @@
|
|||
|
||||
(define-compiler-macro coerce (&whole form value type &environment env)
|
||||
(expand-coerce form value type env))
|
||||
|
||||
(trace c::expand-coerce)
|
||||
|
|
|
|||
|
|
@ -14,6 +14,61 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(define-condition compiler-message (condition)
|
||||
((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)))
|
||||
|
||||
(define-condition compiler-note (compiler-message simple-condition warning) ())
|
||||
|
||||
(define-condition compiler-warning (compiler-message simple-condition style-warning) ())
|
||||
|
||||
(define-condition compiler-error (compiler-message simple-error) ())
|
||||
|
||||
(define-condition compiler-fatal-error (compiler-error) ())
|
||||
|
||||
(define-condition compiler-internal-error (compiler-fatal-error) ())
|
||||
|
||||
(define-condition compiler-undefined-variable (compiler-message warning)
|
||||
((variable :initarg :name :initform nil))
|
||||
(:report
|
||||
(lambda (condition stream)
|
||||
(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 handle-note (c)
|
||||
(when *suppress-compiler-notes*
|
||||
(muffle-warning c)))
|
||||
|
||||
(defun handle-warning (c)
|
||||
(push c *compiler-conditions*)
|
||||
(when *suppress-compiler-warnings*
|
||||
(muffle-warning c)))
|
||||
|
||||
(defun handle-error (c)
|
||||
(push c *compiler-conditions*)
|
||||
(format t "~&~@<;;; ~@;Error:~%~A~:>" c)
|
||||
(invoke-restart (find-restart-never-fail 'abort-form c)))
|
||||
|
||||
(defmacro with-compiler-env ((error-flag) &body body)
|
||||
`(with-lock (+load-compile-lock+)
|
||||
(restart-case
|
||||
(handler-bind ((compiler-note #'handle-note)
|
||||
(compiler-warning #'handle-warning)
|
||||
(compiler-error #'handle-error)
|
||||
(compiler-fatal-error #'handle-fatal-error))
|
||||
(let ,+init-env-form+
|
||||
(setf ,error-flag nil)
|
||||
,@body))
|
||||
(abort (c) (setf ,error-flag t))
|
||||
(abort-form (c) (setf ,error-flag t)))))
|
||||
|
||||
(defvar *c1form-level* 0)
|
||||
(defun print-c1forms (form)
|
||||
(cond ((consp form)
|
||||
|
|
@ -34,12 +89,14 @@
|
|||
(defun print-var (var-object stream)
|
||||
(format stream "#<a VAR: ~A KIND: ~A>" (var-name var-object) (var-kind var-object)))
|
||||
|
||||
(defun cmperr (string &rest args &aux (*print-case* :upcase))
|
||||
(print-current-form)
|
||||
(format t "~&;;; Error: ")
|
||||
(apply #'format t string args)
|
||||
(incf *error-count*)
|
||||
(throw *cmperr-tag* '*cmperr-tag*))
|
||||
(defun cmpprogress (&rest args)
|
||||
(when *compile-verbose*
|
||||
(apply #'format t args)))
|
||||
|
||||
(defun cmperr (string &rest args)
|
||||
(signal 'compiler-error
|
||||
:format-control string
|
||||
:format-arguments args))
|
||||
|
||||
(defun check-args-number (operator args &optional (min 0) (max nil))
|
||||
(let ((l (length args)))
|
||||
|
|
@ -49,41 +106,35 @@
|
|||
(too-many-args operator max l))))
|
||||
|
||||
(defun too-many-args (name upper-bound n &aux (*print-case* :upcase))
|
||||
(print-current-form)
|
||||
(format t
|
||||
"~&;;; ~S requires at most ~R argument~:p, ~
|
||||
but ~R ~:*~[were~;was~:;were~] supplied.~%"
|
||||
(cmperr "~S requires at most ~R argument~:p, but ~R ~:*~[were~;was~:;were~] supplied.~%"
|
||||
name
|
||||
upper-bound
|
||||
n)
|
||||
(incf *error-count*)
|
||||
(throw *cmperr-tag* '*cmperr-tag*))
|
||||
n))
|
||||
|
||||
(defun too-few-args (name lower-bound n &aux (*print-case* :upcase))
|
||||
(print-current-form)
|
||||
(format t
|
||||
"~&;;; ~S requires at least ~R argument~:p, ~
|
||||
but only ~R ~:*~[were~;was~:;were~] supplied.~%"
|
||||
(defun too-few-args (name lower-bound n)
|
||||
(cmperr "~S requires at least ~R argument~:p, but only ~R ~:*~[were~;was~:;were~] supplied.~%"
|
||||
name
|
||||
lower-bound
|
||||
n)
|
||||
(incf *error-count*)
|
||||
(throw *cmperr-tag* '*cmperr-tag*))
|
||||
n))
|
||||
|
||||
(defun cmpwarn (string &rest args &aux (*print-case* :upcase))
|
||||
(unless *suppress-compiler-warnings*
|
||||
(print-current-form)
|
||||
(format t "~&;;; Warning: ")
|
||||
(apply #'format t string args)
|
||||
(terpri))
|
||||
nil)
|
||||
(defun warn-or-note (message &rest args)
|
||||
(declare (si::c-local))
|
||||
(let ((condition (apply #'make-condition args)))
|
||||
(restart-case (signal condition)
|
||||
(muffle-warning ()
|
||||
:REPORT "Skip warning"
|
||||
(return-from warn-or-note nil)))
|
||||
(format *error-output* "~&;;; ~A: ~A~%" message condition)))
|
||||
|
||||
(defun cmpnote (string &rest args &aux (*print-case* :upcase))
|
||||
(unless *suppress-compiler-notes*
|
||||
(format t "~&;;; Note: ")
|
||||
(apply #'format t string args)
|
||||
(terpri))
|
||||
nil)
|
||||
(defun cmpwarn (string &rest args)
|
||||
(warn-or-note "Warning" 'compiler-warning
|
||||
:format-control string
|
||||
:format-arguments args))
|
||||
|
||||
(defun cmpnote (string &rest args)
|
||||
(warn-or-note "Note" 'compiler-note
|
||||
:format-control string
|
||||
:format-arguments args))
|
||||
|
||||
(defun print-current-form ()
|
||||
(unless *suppress-compiler-notes*
|
||||
|
|
@ -99,19 +150,14 @@
|
|||
(when (and name (not *suppress-compiler-notes*))
|
||||
(format t "~&;;; Emitting code for ~s.~%" name))))
|
||||
|
||||
(defun undefined-variable (sym &aux (*print-case* :upcase))
|
||||
(print-current-form)
|
||||
(format t
|
||||
"~&;;; The variable ~s is undefined.~
|
||||
~%;;; The compiler will assume this variable is a global.~%"
|
||||
sym)
|
||||
nil)
|
||||
|
||||
(defun undefined-variable (sym)
|
||||
(signal 'compiler-undefined-variable :name sym))
|
||||
|
||||
(defun baboon (&aux (*print-case* :upcase))
|
||||
(print-current-form)
|
||||
(incf *error-count*)
|
||||
(error "~&;;; A bug was found in the compiler. Contact jjgarcia@users.sourceforge.net.~%"))
|
||||
|
||||
(signal 'compiler-internal-error
|
||||
:format-control "A bug was found in the compiler. Contact jjgarcia@users.sourceforge.net"
|
||||
:format-arguments nil))
|
||||
|
||||
(defmacro with-cmp-protection (main-form error-form)
|
||||
`(let* ((si::*break-enable* *compiler-break-enable*)
|
||||
(throw-flag t))
|
||||
|
|
@ -125,12 +171,12 @@
|
|||
(cmperr "~&;;; The form ~s was not evaluated successfully.~
|
||||
~%;;; You are recommended to compile again.~%"
|
||||
form)))
|
||||
|
||||
|
||||
(defun cmp-macroexpand (form &optional (env *cmp-env*))
|
||||
(with-cmp-protection (macroexpand form env)
|
||||
(cmperr "~&;;; The macro form ~S was not expanded successfully.~
|
||||
~%;;; You are recommended to compile again.~%" form)))
|
||||
|
||||
|
||||
(defun cmp-expand-macro (fd form &optional (env *cmp-env*))
|
||||
(with-cmp-protection
|
||||
(let ((new-form (funcall *macroexpand-hook* fd form env)))
|
||||
|
|
|
|||
|
|
@ -250,7 +250,7 @@
|
|||
:test #'(lambda (k record) (eq k (first record))))))
|
||||
(if x
|
||||
(progn
|
||||
(cmpnote "Reusing keywords lists for ~S" keywords)
|
||||
(cmpnote "~@<Reusing keywords lists for ~_~A~@:>" keywords)
|
||||
(second (elt *permanent-objects* x)))
|
||||
(prog1
|
||||
(add-object (pop keywords) :duplicate t :permanent t)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue