← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/cmp/cmputil.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-06-21 09:21:21 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20060621092121-txz1f21lj0wh0f67
Tags: 0.9h-20060617-1
* New upstream version
* Updated standards version without real changes. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/cmp/cmputil.lsp
115
115
;  (throw *cmperr-tag* '*cmperr-tag*) DEBUG
116
116
)
117
117
 
118
 
(defun cmp-eval (form &aux (throw-flag t))
119
 
  (unwind-protect
120
 
       (prog1
121
 
           (cmp-toplevel-eval form)
122
 
         (setq throw-flag nil))
123
 
    (when throw-flag
124
 
      (let ((*print-case* :upcase))
125
 
        (print-current-form)
126
 
        (format t "~&;;; The form ~s was not evaluated successfully.~
127
 
                   ~%;;; You are recommended to compile again.~%"
128
 
                form)))))
129
 
 
130
 
 
131
 
(defun cmp-macroexpand (form &aux env (throw-flag t))
132
 
  ;; Obtain the local macro environment for expansion.
133
 
  (dolist (v *funs*)
134
 
    (when (consp v) (push v env)))
135
 
  (when env (setq env (cons nil (nreverse env))))
136
 
  (unwind-protect
137
 
      (prog1
138
 
          (cmp-toplevel-eval `(macroexpand ',form ',env))
139
 
        (setq throw-flag nil))
140
 
    (when throw-flag
141
 
      (let ((*print-case* :upcase))
142
 
        (print-current-form)
143
 
        (format t
144
 
                "~&;;; The macro form ~s was not expanded successfully.~
145
 
                   ~%;;; You are recommended to compile again.~%"
146
 
                form)))))
147
 
 
148
 
(defun cmp-expand-macro (fd fname args &aux env (throw-flag t))
149
 
  (dolist (v *funs*)
150
 
    (when (consp v) (push v env)))
151
 
  (when env (setq env (cons nil (nreverse env))))
152
 
  (unwind-protect
153
 
      (prog1
154
 
          (cmp-toplevel-eval
155
 
           `(funcall *macroexpand-hook* ',fd ',(cons fname args) ',env))
156
 
        (setq throw-flag nil))
157
 
    (if throw-flag
158
 
        (let ((*print-case* :upcase))
159
 
          (print-current-form)
160
 
          (format t
161
 
                  "~&;;; The macro form (~s ...) was not expanded successfully.~
162
 
                   ~%;;; You are recommended to compile again.~%"
163
 
                  fname)))))
164
 
 
165
 
(defun cmp-expand-compiler-macro (fd fname args &aux env (throw-flag t))
166
 
  (dolist (v *funs*)
167
 
    (when (consp v) (push v env)))
168
 
  (when env (setq env (cons nil (nreverse env))))
169
 
  (let ((form (cons fname args)))
170
 
    (unwind-protect
171
 
         (let ((new-form (cmp-toplevel-eval `(funcall *macroexpand-hook* ',fd ',form ',env))))
172
 
           (setq throw-flag nil)
173
 
           (values new-form (not (eql new-form form))))
174
 
      (when throw-flag
175
 
          (let ((*print-case* :upcase))
176
 
            (print-current-form)
177
 
            (format t
178
 
                    "~&;;; The macro form (~s ...) was not expanded successfully.~
179
 
                   ~%;;; You are recommended to compile again.~%"
180
 
                    fname))))))
181
 
 
182
 
(defun cmp-toplevel-eval (form)
183
 
   (let*
184
 
     #-:CCL
 
118
(defmacro with-cmp-protection (main-form error-form)
 
119
  `(let* #+nil
185
120
     ((sys::*ihs-base* sys::*ihs-top*)
186
121
      (sys::*ihs-top* (sys::ihs-top 'cmp-toplevel-eval))
187
122
      (*break-enable* *compiler-break-enable*)
188
123
      (sys::*break-hidden-packages*
189
124
       (cons (find-package 'compiler)
190
 
             sys::*break-hidden-packages*)))
191
 
     #+:CCL
192
 
     ((*break-on-errors* *compiler-break-enable*))
193
 
         (eval form)))
 
125
             sys::*break-hidden-packages*))
 
126
      (throw-flag t))
 
127
     ((*break-enable* *compiler-break-enable*)
 
128
      (throw-flag t))
 
129
     (unwind-protect
 
130
         (multiple-value-prog1 ,main-form
 
131
           (setf throw-flag nil))
 
132
       (when throw-flag ,error-form))))
 
133
 
 
134
(defun cmp-eval (form)
 
135
  (with-cmp-protection (eval form)
 
136
    (let ((*print-case* :upcase))
 
137
      (print-current-form)
 
138
      (format t "~&;;; The form ~s was not evaluated successfully.~
 
139
                 ~%;;; You are recommended to compile again.~%"
 
140
              form))))
 
141
 
 
142
(defun cmp-macroexpand (form &optional (env *cmp-env*))
 
143
  (with-cmp-protection (macroexpand form env)
 
144
    (let ((*print-case* :upcase))
 
145
      (print-current-form)
 
146
      (format t "~&;;; The macro form ~S was not expanded successfully.~
 
147
                 ~%;;; You are recommended to compile again.~%" form))))
 
148
 
 
149
(defun cmp-expand-macro (fd form &optional (env *cmp-env*))
 
150
  (with-cmp-protection
 
151
    (let ((new-form (funcall *macroexpand-hook* fd form env)))
 
152
      (values new-form (not (eql new-form form))))
 
153
    (let ((*print-case* :upcase))
 
154
      (print-current-form)
 
155
      (format t "~&;;; The macro form ~S was not expanded successfully.~
 
156
                 ~%;;; You are recommended to compile again.~%" form))))
194
157
 
195
158
(defun si::compiler-clear-compiler-properties (symbol)
196
159
  #-:CCL