/[gcl]/gcl/cmpnew/gcl_cmputil.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmputil.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:33 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:01 2003 UTC
# Line 0  Line 1 
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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26