← Back to branch summary

~ubuntu-branches/ubuntu/vivid/gcl/vivid

« back to all changes in this revision

Viewing changes to cmpnew/cmputil.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2002-03-04 14:29:59 UTC
  • Revision ID: james.westby@ubuntu.com-20020304142959-dey14w08kr7lldu3
Tags: upstream-2.5.0.cvs20020219
Import upstream version 2.5.0.cvs20020219

Show diffs side-by-side

added added

removed removed

Lines of Context:
cmpnew/cmputil.lsp
 
1
;;; CMPUTIL  Miscellaneous Functions.
 
2
;;;
 
3
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
4
 
 
5
;; This file is part of GNU Common Lisp, herein referred to as GCL
 
6
;;
 
7
;; GCL is free software; you can redistribute it and/or modify it under
 
8
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
9
;; the Free Software Foundation; either version 2, or (at your option)
 
10
;; any later version.
 
11
;; 
 
12
;; GCL is distributed in the hope that it will be useful, but WITHOUT
 
13
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
14
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
15
;; License for more details.
 
16
;; 
 
17
;; You should have received a copy of the GNU Library General Public License 
 
18
;; along with GCL; see the file COPYING.  If not, write to the Free Software
 
19
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
20
 
 
21
 
 
22
(in-package 'compiler)
 
23
 
 
24
(export '(*suppress-compiler-warnings*
 
25
          *suppress-compiler-notes*
 
26
          *compiler-break-enable*))
 
27
 
 
28
(defmacro safe-compile (&rest forms) `(when *safe-compile* ,@forms))
 
29
 
 
30
(defvar *current-form* '|compiler preprocess|)
 
31
(defvar *first-error* t)
 
32
(defvar *error-count* 0)
 
33
 
 
34
(defconstant *cmperr-tag* (cons nil nil))
 
35
 
 
36
(defun cmperr (string &rest args &aux (*print-case* :upcase))
 
37
  (print-current-form)
 
38
  (format t "~&;;; ")
 
39
  (apply #'format t string args)
 
40
  (incf *error-count*)
 
41
  (throw *cmperr-tag* '*cmperr-tag*))
 
42
 
 
43
(defmacro cmpck (condition string &rest args)
 
44
  `(if ,condition (cmperr ,string ,@args)))
 
45
 
 
46
(defun too-many-args (name upper-bound n &aux (*print-case* :upcase))
 
47
  (print-current-form)
 
48
  (format t
 
49
          ";;; ~S requires at most ~R argument~:p, ~
 
50
          but ~R ~:*~[were~;was~:;were~] supplied.~%"
 
51
          name
 
52
          upper-bound
 
53
          n)
 
54
  (incf *error-count*)
 
55
  (throw *cmperr-tag* '*cmperr-tag*))
 
56
 
 
57
(defun too-few-args (name lower-bound n &aux (*print-case* :upcase))
 
58
  (print-current-form)
 
59
  (format t
 
60
          ";;; ~S requires at least ~R argument~:p, ~
 
61
          but only ~R ~:*~[were~;was~:;were~] supplied.~%"
 
62
          name
 
63
          lower-bound
 
64
          n)
 
65
  (incf *error-count*)
 
66
  (throw *cmperr-tag* '*cmperr-tag*))
 
67
 
 
68
(defvar *suppress-compiler-warnings* nil)
 
69
 
 
70
(defun cmpwarn (string &rest args &aux (*print-case* :upcase))
 
71
  (unless *suppress-compiler-warnings*
 
72
    (print-current-form)
 
73
    (format t ";; Warning: ")
 
74
    (apply #'format t string args)
 
75
    (terpri))
 
76
  nil)
 
77
 
 
78
(defvar *suppress-compiler-notes* nil)
 
79
 
 
80
(defun cmpnote (string &rest args &aux (*print-case* :upcase))
 
81
  (unless *suppress-compiler-notes* 
 
82
    (terpri)
 
83
    (format t ";; Note: ")
 
84
    (apply #'format t string args))
 
85
  nil)
 
86
 
 
87
(defun print-current-form ()
 
88
  (when *first-error*
 
89
        (setq *first-error* nil)
 
90
        (fresh-line)
 
91
        (cond
 
92
         ((and (consp *current-form*)
 
93
               (eq (car *current-form*) 'si:|#,|))
 
94
          (format t "; #,~s is being compiled.~%" (cdr *current-form*)))
 
95
         (t
 
96
          (let ((*print-length* 2)
 
97
                (*print-level* 2))
 
98
               (format t "; ~s is being compiled.~%" *current-form*)))))
 
99
  nil)
 
100
 
 
101
(defun undefined-variable (sym &aux (*print-case* :upcase))
 
102
  (print-current-form)
 
103
  (format t
 
104
          ";; The variable ~s is undefined.~%~
 
105
           ;; The compiler will assume this variable is a global.~%"
 
106
          sym)
 
107
  nil)
 
108
 
 
109
(defun baboon (&aux (*print-case* :upcase))
 
110
  (print-current-form)
 
111
  (format t ";;; A bug was found in the compiler.  Contact Taiichi.~%")
 
112
  (incf *error-count*)
 
113
  (break)
 
114
;  (throw *cmperr-tag* '*cmperr-tag*)
 
115
)
 
116
 
 
117
;;; Internal Macros with type declarations
 
118
 
 
119
(defmacro dolist* ((v l &optional (val nil)) . body)
 
120
  (let ((temp (gensym)))
 
121
  `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
 
122
        ((endp ,temp) ,val)
 
123
        (declare (object ,v))
 
124
        ,@body)))
 
125
 
 
126
(defmacro dolist** ((v l &optional (val nil)) . body)
 
127
  (let ((temp (gensym)))
 
128
  `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
 
129
        ((endp ,temp) ,val)
 
130
        (declare (object ,temp ,v))
 
131
        ,@body)))
 
132
 
 
133
(defmacro dotimes* ((v n &optional (val nil)) . body)
 
134
  (let ((temp (gensym)))
 
135
   `(do* ((,temp ,n) (,v 0 (1+ ,v)))
 
136
         ((>= ,v ,temp) ,val)
 
137
         (declare (fixnum ,v))
 
138
         ,@body)))
 
139
 
 
140
(defmacro dotimes** ((v n &optional (val nil)) . body)
 
141
  (let ((temp (gensym)))
 
142
   `(do* ((,temp ,n) (,v 0 (1+ ,v)))
 
143
         ((>= ,v ,temp) ,val)
 
144
         (declare (fixnum ,temp ,v))
 
145
         ,@body)))
 
146
 
 
147
(defun cmp-eval (form)
 
148
  (let ((x (multiple-value-list (cmp-toplevel-eval `(eval ',form)))))
 
149
    (if (car x)
 
150
        (let ((*print-case* :upcase))
 
151
          (incf *error-count*)
 
152
          (print-current-form)
 
153
          (format t
 
154
                  ";;; The form ~s was not evaluated successfully.~%~
 
155
                  ;;; You are recommended to compile again.~%"
 
156
                  form)
 
157
          nil)
 
158
        (values-list (cdr x)))))
 
159
 
 
160
 
 
161
;(si::putprop 'setf 'c1setf 'c1special)
 
162
 
 
163
;;The PLACE may be a local macro, so we must take care to expand it
 
164
;;before trying to call the macro form of setf, or an error will
 
165
 
 
166
;(defun c1setf (args &aux fd)
 
167
;  (cond ((and
 
168
;          (consp (car args))
 
169
;          (symbolp (caar args))
 
170
;          (setq fd (cmp-macro-function (caar args))))
 
171
;        (c1expr `(setf ,(cmp-expand-macro fd (caar args) (cdar args))
 
172
;                       ,@ (cdr args))))
 
173
;       (t       
 
174
;         (c1expr (cmp-expand-macro (macro-function 'setf)
 
175
;                                  'setf
 
176
;                                  args)))))
 
177
 
 
178
(defun cmp-macroexpand (form &aux env)
 
179
  ;;Obtain the local macro environment for expansion.
 
180
  (dolist (v *funs*)
 
181
          (if (consp v) (push (list (car v) 'macro (cadr v)) env)))
 
182
  (if env (setq env (list nil (nreverse env) nil)))
 
183
  (let ((x (multiple-value-list
 
184
             (cmp-toplevel-eval `(macroexpand ',form ',env)))))
 
185
    (if (car x)
 
186
        (let ((*print-case* :upcase))
 
187
          (incf *error-count*)
 
188
          (print-current-form)
 
189
          (format t
 
190
                  ";;; The macro form ~s was not expanded successfully.~%"
 
191
                  form)
 
192
          `(error "Macro-expansion of ~s failed at compile time." ',form))
 
193
        (cadr x))))
 
194
 
 
195
(defun cmp-macroexpand-1 (form &aux env)
 
196
  (dolist (v *funs*)
 
197
          (if (consp v) (push (list (car v) 'macro (cadr v)) env))) 
 
198
  (let ((x (multiple-value-list (cmp-toplevel-eval `(macroexpand-1 ',form
 
199
                                                                   ',env)))))
 
200
    (if (car x)
 
201
        (let ((*print-case* :upcase))
 
202
          (incf *error-count*)
 
203
          (print-current-form)
 
204
          (format t
 
205
                  ";;; The macro form ~s was not expanded successfully.~%"
 
206
                  form)
 
207
          `(error "Macro-expansion of ~s failed at compile time." ',form))
 
208
        (cadr x))))
 
209
 
 
210
(defun cmp-expand-macro (fd fname args &aux env)
 
211
  (dolist (v *funs*)
 
212
          (if (consp v) (push (list (car v) 'macro (cadr v)) env)))
 
213
  (and *record-call-info* (add-macro-callee fname))
 
214
  (if env (setq env (list nil (nreverse env) nil)))
 
215
  (let ((x (multiple-value-list
 
216
            (cmp-toplevel-eval
 
217
             `(funcall *macroexpand-hook* ',fd ',(cons fname args) ',env)))))
 
218
    (if (car x)
 
219
        (let ((*print-case* :upcase))
 
220
          (incf *error-count*)
 
221
          (print-current-form)
 
222
          (format t
 
223
            ";;; The macro form (~s ...) was not expanded successfully.~%"
 
224
            fname)
 
225
          `(error "Macro-expansion of ~s failed at compile time."
 
226
                  ',(cons fname args)))
 
227
        (cadr x))))
 
228
 
 
229
(defvar *compiler-break-enable* nil)
 
230
 
 
231
(defun cmp-toplevel-eval (form)
 
232
   (let* ((si::*ihs-base* si::*ihs-top*)
 
233
          (si::*ihs-top* (1- (si::ihs-top)))
 
234
          (*break-enable* *compiler-break-enable*)
 
235
          (si::*break-hidden-packages*
 
236
           (cons (find-package 'compiler)
 
237
                 si::*break-hidden-packages*)))
 
238
         (si:error-set form)))
 
239
 
 
240
(dolist (v '(si::cdefn lfun inline-safe inline-unsafe
 
241
                       inline-always c1conditional c2 c1 c1+ co1
 
242
                       si::structure-access co1special
 
243
                       top-level-macro t3 t2 t1 package-operation))
 
244
           (si::putprop v t 'compiler-prop ))
 
245
 
 
246
(defun  compiler-def-hook (symbol code) symbol code nil)
 
247
 
 
248
(defun compiler-clear-compiler-properties (symbol code)
 
249
  code
 
250
  (let ((v (symbol-plist symbol)) w)
 
251
    (tagbody
 
252
      top
 
253
      (setq w (car v))
 
254
      (cond ((and (symbolp w)
 
255
                  (get w 'compiler-prop))
 
256
 
 
257
             (setq v (cddr v))
 
258
             (remprop symbol w))
 
259
            (t (setq v (cddr v))))
 
260
      (or (null v) (go top)))
 
261
    (compiler-def-hook symbol code)
 
262
    ))
 
263
 
 
264
;hi