cmputil.lsp 11.3 KB
Newer Older
1
2
3
4
5
6
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; CMPUTIL  --  Miscellaneous Functions.

;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
7
;;;;  Copyright (c) 2010-2017, Jean-Claude Beaudoin.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
;;;;
;;;;    ECoLisp is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Lesser General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 3 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../../Copyright' for full details.

(in-package "COMPILER")

(define-condition compiler-message (simple-condition)
  ((prefix :initform "Note" :accessor compiler-message-prefix)
   (file :initarg :file :initform *compile-file-pathname*
	 :accessor compiler-message-file)
   (end-position :initarg :end-position :initform *compile-file-end-position*
		 :accessor compiler-message-file-end-position)
   (form :initarg :form :initform *original-current-form*
	 :accessor compiler-message-form))
  (:REPORT
   (lambda (c stream)
     (let ((position (compiler-message-file-end-position c)))
       (if (< 0 position)
	   (let ((*print-length* 3)
		 (*print-level* 2)
		 )
33
	     (format stream "~A: in file ~A, end position ~D,~%    and form: ~A~%"
34
35
36
		     (compiler-message-prefix c)
		     (compiler-message-file c) position (compiler-message-form c)))
	   (format stream "~A: " (compiler-message-prefix c)))
37
       (format stream "  ~?"
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
	       (simple-condition-format-control c)
	       (simple-condition-format-arguments c))))))

(define-condition compiler-note (compiler-message) ())

(define-condition compiler-warning (compiler-message warning)
  ((prefix :initform "Warning")))

(define-condition compiler-style-warning (compiler-message style-warning)
  ((prefix :initform "Style Warning")))

(define-condition compiler-error (compiler-message error)
  ((prefix :initform "Error")))

(define-condition compiler-fatal-error (compiler-error) ())

(define-condition compiler-internal-error (compiler-fatal-error)
  ((prefix :initform "Internal error")))

(define-condition compiler-undefined-variable (compiler-style-warning)
  ((prefix :initform "Style Warning")
   (variable :initarg :name :initform nil))
  (:report
   (lambda (condition stream)
     (let ((position (compiler-message-file-end-position condition)))
       (if (< 0 position)
	   (let ((*print-length* 3)
		 (*print-level* 2)
		 )
	     (format stream "~A: in file ~A, end position ~D,~%   and form: ~A~%"
		     (compiler-message-prefix condition)
		     (compiler-message-file condition)
		     position 
		     (compiler-message-form condition)))
	 (format stream "~A: " (compiler-message-prefix condition)))
       (format stream "Variable ~A was undefined. Compiler assumes it is a global."
	       (slot-value condition 'variable))))))

(defun print-compiler-message (c stream)
  (unless (typep c *suppress-compiler-messages*)
    (format stream "~&~@<;;; ~@;~A~:>" c)
    ;;(format stream "~&;;; ~A" c)
    ;;(print ";;; " stream) (princ c stream)
    ))

(defun handle-note (c)
  (declare (ignore c))
  nil)

(defun handle-warning/error (c)
  (push c *compiler-conditions*)
  nil)

(defun handle-internal-error (c)
  (push c *compiler-conditions*)
  (invoke-debugger c) ;; give *debugger-hook* a chance to handle this
  (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-protection* nil))
	   (do-compilation-unit closure)))
	((null *active-protection*)
	 (let* ((*active-protection* t)
		(*pending-actions* nil))
	   (unwind-protect (do-compilation-unit closure)
	     (loop for action in *pending-actions*
		do (funcall action)))))
	(t
	 (funcall closure))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (si::reopen-package :cl))
(defmacro cl:with-compilation-unit ((&rest options) &body body)
 `(si:without-fpe *compiler-floating-point-exclusion-set*
     (do-compilation-unit #'(lambda () ,@body) ,@options)))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (si::close-package :cl))

(defun compiler-debugger (outer-hook condition old-hook)
  (declare (ignore old-hook))
  (when *compiler-break-enable*
    (when outer-hook
      (funcall outer-hook condition outer-hook))
    (si::default-debugger condition))
  (cmperr "~A" condition) ;; Wrap condition in a compiler-error to give it source context.
  (abort))

(defmacro with-compiler-env ((compiler-conditions) &body body)
  `(let ((*compiler-conditions* nil))
     (declare (special *compiler-conditions*))
     (restart-case
	 (handler-bind (((and error (not compiler-message)) #'handle-internal-error))
	   (handler-bind ((compiler-note #'handle-note)
			  (warning #'handle-warning/error)
			  (compiler-error #'handle-warning/error)
			  ((and compiler-message
				(not (or compiler-note warning compiler-error)))
			   #'handle-note) ;; not really expected...
			  )
             (mt:with-lock (mt::+load-compile-lock+)
	        (let ,+init-env-form+
                  (with-compilation-unit ()
                     ,@body)))))
       (abort (&optional c)
	      :report "Abort compilation."
	      (push (if c c :aborted) *compiler-conditions*)
	      (format t "~&;;; Compilation failed!~%")))
     (setf ,compiler-conditions *compiler-conditions*)))

(defvar *c1form-level* 0)
(defun print-c1forms (form)
  (cond ((consp form)
	 (let ((*c1form-level* (1+ *c1form-level*)))
	   (mapc #'print-c1forms form)))
	((c1form-p form)
	 (format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parent form))
	 (print-c1forms (c1form-args form))
	 form
	 )))

(defun print-ref (ref-object stream)
  (let ((name (ref-name ref-object)))
    (if name
	(format stream "#<a ~A: ~A>" (type-of ref-object) name)
	(format stream "#<a ~A>" (type-of ref-object)))))

(defun print-var (var-object stream)
  (format stream "#<a VAR: ~A KIND: ~A>" (var-name var-object) (var-kind var-object)))

(defun cmpprogress (&rest args)
  (when *compile-verbose*
    (apply #'format t args)))

(defun cmperr (string &rest args)
  (let ((c (make-condition 'compiler-error
			   :format-control string
			   :format-arguments args)))
    (signal c)
    (print-compiler-message c t)
    (abort)))

(defun check-args-number (operator args &optional (min 0) (max nil))
  (let ((l (length args)))
    (when (< l min)
      (too-few-args operator min l))
    (when (and max (> l max))
      (too-many-args operator max l))))

(defun too-many-args (name upper-bound n &aux (*print-case* :upcase))
  (cmperr "~S requires at most ~R argument~:p, but ~R ~:*~[were~;was~:;were~] supplied.~%"
          name
          upper-bound
          n))

(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))

(defun do-cmpwarn (&rest args)
  (let ((condition (apply #'make-condition args)))
    (restart-case (signal condition)
      (muffle-warning ()
	:REPORT "Skip warning"
	(return-from do-cmpwarn nil)))
    (print-compiler-message condition t)))

(defun cmpwarn-style (string &rest args)
  (unless *suppress-compiler-warnings*
    (do-cmpwarn 'compiler-style-warning :format-control string :format-arguments args)))

(defun cmpwarn (string &rest args)
  (unless *suppress-compiler-warnings*
    (do-cmpwarn 'compiler-warning :format-control string :format-arguments args)))

(defun cmpnote (string &rest args)
  (unless *suppress-compiler-notes*
    (do-cmpwarn 'compiler-note :format-control string :format-arguments args)))

(defun print-current-form ()
  (when *compile-print*
    (let ((*print-length* 2)
	  (*print-level* 2))
      (format t "~&;;; Compiling ~s.~%" *original-current-form*)))
  nil)

(defun print-emitting (f)
  (when *compile-print*
    (let* ((name (or (fun-name f) (fun-description f))))
      (when name
	(format t "~&;;; Emitting code for ~s.~%" name)))))

(defun undefined-variable (sym)
  (do-cmpwarn 'compiler-undefined-variable :name sym))
  
(defun baboon (&aux (*print-case* :upcase))
  (signal 'compiler-internal-error
	  :format-control "A bug was found in the compiler."
	  :format-arguments nil))
  
(defmacro with-cmp-protection (main-form error-form)
  `(let* ((si::*break-enable* *compiler-break-enable*)
          (throw-flag t))
     (unwind-protect
	 (multiple-value-prog1
             (if *compiler-break-enable*
                 (handler-bind (((and error (not compiler-error)) #'invoke-debugger))
                   ,main-form)
                 ,main-form)
           (setf throw-flag nil))
       (when throw-flag ,error-form)))) ;; this intercepts any non-local transfer! JCB

(defun cmp-eval (form)
  (with-cmp-protection (eval form)
    (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 
    (handler-case (macroexpand form env)
266
      (serious-condition #|program-error|# (condition) ;; program-error was much too weak. JCB
267
268
269
270
271
272
273
274
275
276
	 (cmperr "Macro expansion of form: ~S~
                  ~%failed with this condition: ~A." form condition)))
    (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 
	   (handler-case
	       (funcall *macroexpand-hook* fd form env)
277
	     (serious-condition #|program-error|# (condition) ;; program-error was much too weak. JCB
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
	       (cmperr "Macro expansion of form: ~S~
                        ~%failed with this condition: ~A." form condition)))))
      (values new-form (not (eql new-form form))))
    (cmperr "The macro form ~S was not expanded successfully.~
             ~%You are recommended to compile again." form)))

#-(or mkcl-min mkcl-bootstrap mkcl-cmp-bootstrap)
(defun clear-compiler-properties (symbol)
  (rem-sysprop symbol 't1)
  (rem-sysprop symbol 't2)
  (rem-sysprop symbol 't3)
  (rem-sysprop symbol 'c1)
  (rem-sysprop symbol 'c2)
  (rem-sysprop symbol 'c1conditional)
  (rem-sysprop symbol ':inline-always)
  (rem-sysprop symbol ':inline-unsafe)
  (rem-sysprop symbol ':inline-safe)
295
  (rem-sysprop symbol 'si::lfun))
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
  
(defun lisp-to-c-function-name (obj)
  "Translate Lisp function name object prin1 representation to valid C function name"
  #+(or)
  (and obj 
       (map 'string 
            #'(lambda (c)
                (let ((cc (char-code c)))
                  (if (or (<= #.(char-code #\a) cc #.(char-code #\z))
                          (<= #.(char-code #\0) cc #.(char-code #\9))) ;; And you call that mangling! LOL JCB
                      c #\_)))
            (string-downcase (prin1-to-string obj))))
  #+(and)
  (typecase obj
    (string (si:mangle-string obj))
    (symbol (si:mangle-symbol obj))
    (t (si:mangle-string (prin1-to-string obj)))) ;; the (setf foo) case.
  )

(defun proper-list-p (x &optional test)
  #+(or)
  (and (listp x)
       (handler-case (list-length x) (type-error (c) nil))
       (or (null test) (every test x)))
  ;; This version traverses the list only once and does not create a closure. JCB
  (and (listp x)
       (do ((tail x (cdr tail)))
	   ((not (consp tail)) (null tail))
	 (if test (if (not (funcall test (car tail))) (return nil)))
	 )
       )
  )