1
;;;; CMPUTIL -- Miscellaneous Functions.
3
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
4
;;;; Copyright (c) 1990, Giuseppe Attardi.
6
;;;; ECoLisp is free software; you can redistribute it and/or
7
;;;; modify it under the terms of the GNU Library General Public
8
;;;; License as published by the Free Software Foundation; either
9
;;;; version 2 of the License, or (at your option) any later version.
11
;;;; See file '../Copyright' for full details.
13
(in-package "COMPILER")
15
(defvar *c1form-level* 0)
16
(defun print-c1forms (form)
18
(let ((*c1form-level* (1+ *c1form-level*)))
19
(mapc #'print-c1forms form)))
21
(format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parent form))
22
(print-c1forms (c1form-args form))
26
(defun print-ref (ref-object stream)
27
(let ((name (ref-name ref-object)))
29
(format stream "#<a ~A: ~A>" (type-of ref-object) name)
30
(format stream "#<a ~A>" (type-of ref-object)))))
32
(defun print-var (var-object stream)
33
(format stream "#<a VAR: ~A KIND: ~A>" (var-name var-object) (var-kind var-object)))
35
(defun cmperr (string &rest args &aux (*print-case* :upcase))
37
(format t "~&;;; Error: ")
38
(apply #'format t string args)
40
(throw *cmperr-tag* '*cmperr-tag*))
42
(defun check-args-number (operator args &optional (min 0) (max nil))
43
(let ((l (length args)))
45
(too-few-args operator min l))
46
(when (and max (> l max))
47
(too-many-args operator max l))))
49
(defun too-many-args (name upper-bound n &aux (*print-case* :upcase))
52
"~&;;; ~S requires at most ~R argument~:p, ~
53
but ~R ~:*~[were~;was~:;were~] supplied.~%"
58
(throw *cmperr-tag* '*cmperr-tag*))
60
(defun too-few-args (name lower-bound n &aux (*print-case* :upcase))
63
"~&;;; ~S requires at least ~R argument~:p, ~
64
but only ~R ~:*~[were~;was~:;were~] supplied.~%"
69
(throw *cmperr-tag* '*cmperr-tag*))
71
(defun cmpwarn (string &rest args &aux (*print-case* :upcase))
72
(unless *suppress-compiler-warnings*
74
(format t "~&;;; Warning: ")
75
(apply #'format t string args)
79
(defun cmpnote (string &rest args &aux (*print-case* :upcase))
80
(unless *suppress-compiler-notes*
81
(format t "~&;;; Note: ")
82
(apply #'format t string args)
86
(defun print-current-form ()
87
(unless *suppress-compiler-notes*
88
(let ((*print-length* 2)
90
(format t "~&;;; Compiling ~s.~%" *current-form*)))
93
(defun print-emitting (f)
94
(let* ((name (fun-name f)))
96
(setf name (fun-description f)))
97
(when (and name (not *suppress-compiler-notes*))
98
(format t "~&;;; Emitting code for ~s.~%" name))))
100
(defun undefined-variable (sym &aux (*print-case* :upcase))
103
"~&;;; The variable ~s is undefined.~
104
~%;;; The compiler will assume this variable is a global.~%"
108
(defun baboon (&aux (*print-case* :upcase))
110
(error "~&;;; A bug was found in the compiler. Contact worm@arrakis.es.~%")
112
t "~&;;; A bug was found in the compiler. Contact worm@arrakis.es.~%")
115
; (throw *cmperr-tag* '*cmperr-tag*) DEBUG
118
(defun cmp-eval (form &aux (throw-flag t))
121
(cmp-toplevel-eval form)
122
(setq throw-flag nil))
124
(let ((*print-case* :upcase))
126
(format t "~&;;; The form ~s was not evaluated successfully.~
127
~%;;; You are recommended to compile again.~%"
131
(defun cmp-macroexpand (form &aux env (throw-flag t))
132
;; Obtain the local macro environment for expansion.
134
(when (consp v) (push v env)))
135
(when env (setq env (cons nil (nreverse env))))
138
(cmp-toplevel-eval `(macroexpand ',form ',env))
139
(setq throw-flag nil))
141
(let ((*print-case* :upcase))
144
"~&;;; The macro form ~s was not expanded successfully.~
145
~%;;; You are recommended to compile again.~%"
148
(defun cmp-expand-macro (fd fname args &aux env (throw-flag t))
150
(when (consp v) (push v env)))
151
(when env (setq env (cons nil (nreverse env))))
155
`(funcall *macroexpand-hook* ',fd ',(cons fname args) ',env))
156
(setq throw-flag nil))
158
(let ((*print-case* :upcase))
161
"~&;;; The macro form (~s ...) was not expanded successfully.~
162
~%;;; You are recommended to compile again.~%"
165
(defun cmp-expand-compiler-macro (fd fname args &aux env (throw-flag t))
167
(when (consp v) (push v env)))
168
(when env (setq env (cons nil (nreverse env))))
169
(let ((form (cons fname args)))
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))))
175
(let ((*print-case* :upcase))
178
"~&;;; The macro form (~s ...) was not expanded successfully.~
179
~%;;; You are recommended to compile again.~%"
182
(defun cmp-toplevel-eval (form)
185
((sys::*ihs-base* sys::*ihs-top*)
186
(sys::*ihs-top* (sys::ihs-top 'cmp-toplevel-eval))
187
(*break-enable* *compiler-break-enable*)
188
(sys::*break-hidden-packages*
189
(cons (find-package 'compiler)
190
sys::*break-hidden-packages*)))
192
((*break-on-errors* *compiler-break-enable*))
195
(defun si::compiler-clear-compiler-properties (symbol)
197
;(sys::unlink-symbol symbol)
198
(rem-sysprop symbol 't1)
199
(rem-sysprop symbol 't2)
200
(rem-sysprop symbol 't3)
201
(rem-sysprop symbol 'c1)
202
(rem-sysprop symbol 'c2)
203
(rem-sysprop symbol 'c1conditional)
204
(rem-sysprop symbol ':inline-always)
205
(rem-sysprop symbol ':inline-unsafe)
206
(rem-sysprop symbol ':inline-safe)
207
(rem-sysprop symbol 'lfun))
209
(defun lisp-to-c-name (obj)
210
"Translate Lisp object prin1 representation to valid C identifier name"
214
(let ((cc (char-code c)))
215
(if (or (<= #.(char-code #\a) cc #.(char-code #\z))
216
(<= #.(char-code #\0) cc #.(char-code #\9)))
218
(string-downcase (prin1-to-string obj)))))
220
(defun proper-list-p (x &optional test)
222
(handler-case (list-length x) (type-error (c) nil))
223
(or (null test) (every test x))))
added
removed
src/cmp/cmputil.lsp
