1 ;;;; bootstrapping fundamental machinery (e.g. DEFUN, DEFCONSTANT,
2 ;;;; DEFVAR) from special forms and primitive functions
4 ;;;; KLUDGE: The bootstrapping aspect of this is now obsolete. It was
5 ;;;; originally intended that this file file would be loaded into a
6 ;;;; Lisp image which had Common Lisp primitives defined, and DEFMACRO
7 ;;;; defined, and little else. Since then that approach has been
8 ;;;; dropped and this file has been modified somewhat to make it work
9 ;;;; more cleanly when used to predefine macros at
10 ;;;; build-the-cross-compiler time.
12 ;;;; This software is part of the SBCL system. See the README file for
13 ;;;; more information.
15 ;;;; This software is derived from the CMU CL system, which was
16 ;;;; written at Carnegie Mellon University and released into the
17 ;;;; public domain. The software is in the public domain and is
18 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
19 ;;;; files for more information.
21 (in-package "SB!IMPL")
25 (defmacro-mundanely in-package (package-designator)
26 `(eval-when (:compile-toplevel :load-toplevel :execute)
27 (setq *package* (find-undeleted-package-or-lose ',package-designator))))
29 ;;;; MULTIPLE-VALUE-FOO
31 (defun list-of-symbols-p (x)
35 (defmacro-mundanely multiple-value-bind (vars value-form &body body)
36 (if (list-of-symbols-p vars)
37 ;; It's unclear why it would be important to special-case the LENGTH=1 case
38 ;; at this level, but the CMU CL code did it, so.. -- WHN 19990411
39 (if (= (length vars) 1)
40 `(let ((,(car vars) ,value-form))
42 (let ((ignore (gensym)))
43 `(multiple-value-call #'(lambda (&optional ,@vars &rest ,ignore)
44 (declare (ignore ,ignore))
47 (error "Vars is not a list of symbols: ~S" vars)))
49 (defmacro-mundanely multiple-value-setq (vars value-form)
50 (unless (list-of-symbols-p vars)
51 (error "Vars is not a list of symbols: ~S" vars))
52 `(values (setf (values ,@vars) ,value-form)))
54 (defmacro-mundanely multiple-value-list (value-form)
55 `(multiple-value-call #'list ,value-form))
57 ;;;; various conditional constructs
59 ;;; COND defined in terms of IF
60 (defmacro-mundanely cond (&rest clauses)
63 (let ((clause (first clauses)))
65 (error "COND clause is not a list: ~S" clause)
66 (let ((test (first clause))
67 (forms (rest clause)))
69 (let ((n-result (gensym)))
70 `(let ((,n-result ,test))
73 (cond ,@(rest clauses)))))
76 (cond ,@(rest clauses)))))))))
78 ;;; other things defined in terms of COND
79 (defmacro-mundanely when (test &body forms)
81 "If the first argument is true, the rest of the forms are
82 evaluated as a PROGN."
83 `(cond (,test nil ,@forms)))
84 (defmacro-mundanely unless (test &body forms)
86 "If the first argument is not true, the rest of the forms are
87 evaluated as a PROGN."
88 `(cond ((not ,test) nil ,@forms)))
89 (defmacro-mundanely and (&rest forms)
90 (cond ((endp forms) t)
91 ((endp (rest forms)) (first forms))
96 (defmacro-mundanely or (&rest forms)
97 (cond ((endp forms) nil)
98 ((endp (rest forms)) (first forms))
100 (let ((n-result (gensym)))
101 `(let ((,n-result ,(first forms)))
104 (or ,@(rest forms))))))))
106 ;;;; various sequencing constructs
108 (defmacro-mundanely prog (varlist &body body-decls)
109 (multiple-value-bind (body decls) (parse-body body-decls nil)
115 (defmacro-mundanely prog* (varlist &body body-decls)
116 (multiple-value-bind (body decls) (parse-body body-decls nil)
122 (defmacro-mundanely prog1 (result &body body)
123 (let ((n-result (gensym)))
124 `(let ((,n-result ,result))
128 (defmacro-mundanely prog2 (form1 result &body body)
129 `(prog1 (progn ,form1 ,result) ,@body))
133 ;;; Should we save the inline expansion of the function named NAME?
134 (defun inline-fun-name-p (name)
136 ;; the normal reason for saving the inline expansion
137 (info :function :inlinep name)
138 ;; another reason for saving the inline expansion: If the
139 ;; ANSI-recommended idiom
140 ;; (DECLAIM (INLINE FOO))
142 ;; (DECLAIM (NOTINLINE FOO))
143 ;; has been used, and then we later do another
145 ;; without a preceding
146 ;; (DECLAIM (INLINE FOO))
147 ;; what should we do with the old inline expansion when we see the
148 ;; new DEFUN? Overwriting it with the new definition seems like
149 ;; the only unsurprising choice.
150 (info :function :inline-expansion-designator name)))
152 (defmacro-mundanely defun (&environment env name args &body body)
153 "Define a function at top level."
155 (unless (symbol-package (fun-name-block-name name))
156 (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name))
157 (multiple-value-bind (forms decls doc) (parse-body body)
158 (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA
161 (block ,(fun-name-block-name name)
163 (lambda `(lambda ,@lambda-guts))
165 (named-lambda `(named-lambda ,name ,@lambda-guts))
167 (cond (;; Does the user not even want to inline?
168 (not (inline-fun-name-p name))
170 (;; Does inlining look too hairy to handle?
171 (not (sb!c:lambda-independent-of-lexenv-p lambda env))
172 (sb!c:maybe-compiler-note
173 "lexical environment too hairy, can't inline DEFUN ~S"
177 ;; FIXME: The only reason that we return
178 ;; LAMBDA-WITH-LEXENV instead of returning bare
179 ;; LAMBDA is to avoid modifying downstream code
180 ;; which expects LAMBDA-WITH-LEXENV. But the code
181 ;; here is the only code which feeds into the
182 ;; downstream code, and the generality of the
183 ;; interface is no longer used, so it'd make sense
184 ;; to simplify the interface instead of using the
185 ;; old general LAMBDA-WITH-LEXENV interface in this
187 `(sb!c:lambda-with-lexenv
188 nil nil nil ; i.e. no DECLS, no MACROS, no SYMMACS
192 ;; In cross-compilation of toplevel DEFUNs, we arrange
193 ;; for the LAMBDA to be statically linked by GENESIS.
195 ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
196 ;; here instead of LAMBDA. The reason is historical:
197 ;; COLD-FSET was written before NAMED-LAMBDA, and has special
198 ;; logic of its own to notify the compiler about NAME.
200 (cold-fset ,name ,lambda)
202 (eval-when (:compile-toplevel :load-toplevel :execute)
203 (sb!c:%compiler-defun ',name ',inline-lambda))
206 ;; In normal compilation (not for cold load) this is
207 ;; where the compiled LAMBDA first appears. In
208 ;; cross-compilation, we manipulate the
209 ;; previously-statically-linked LAMBDA here.
210 #-sb-xc-host ,named-lambda
211 #+sb-xc-host (fdefinition ',name)
214 (defun %defun (name def doc)
215 (declare (type function def))
216 (declare (type (or null simple-string doc)))
217 (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN
219 (/show0 "redefining NAME in %DEFUN")
220 (style-warn "redefining ~S in DEFUN" name))
221 (setf (sb!xc:fdefinition name) def)
223 ;; FIXME: I want to do this here (and fix bug 137), but until the
224 ;; breathtaking CMU CL function name architecture is converted into
225 ;; something sane, (1) doing so doesn't really fix the bug, and
226 ;; (2) doing probably isn't even really safe.
227 #+nil (setf (%fun-name def) name)
230 ;; FIXME: This should use shared SETF-name-parsing logic.
231 (if (and (consp name) (eq (first name) 'setf))
232 (setf (fdocumentation (second name) 'setf) doc)
233 (setf (fdocumentation (the symbol name) 'function) doc)))
236 ;;;; DEFVAR and DEFPARAMETER
238 (defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp))
240 "Define a global variable at top level. Declare the variable
241 SPECIAL and, optionally, initialize it. If the variable already has a
242 value, the old value is not clobbered. The third argument is an optional
243 documentation string for the variable."
245 (declaim (special ,var))
247 `((unless (boundp ',var)
250 `((setf (fdocumentation ',var 'variable) ',doc )))
253 (defmacro-mundanely defparameter (var val &optional (doc nil docp))
255 "Define a parameter that is not normally changed by the program,
256 but that may be changed without causing an error. Declare the
257 variable special and sets its value to VAL, overwriting any
258 previous value. The third argument is an optional documentation
259 string for the parameter."
261 (declaim (special ,var))
264 `((setf (fdocumentation ',var 'variable) ',doc)))
267 ;;;; iteration constructs
269 ;;; (These macros are defined in terms of a function FROB-DO-BODY which
270 ;;; is also used by SB!INT:DO-ANONYMOUS. Since these macros should not
271 ;;; be loaded on the cross-compilation host, but SB!INT:DO-ANONYMOUS
272 ;;; and FROB-DO-BODY should be, these macros can't conveniently be in
273 ;;; the same file as FROB-DO-BODY.)
274 (defmacro-mundanely do (varlist endlist &body body)
276 "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
277 Iteration construct. Each Var is initialized in parallel to the value of the
278 specified Init form. On subsequent iterations, the Vars are assigned the
279 value of the Step form (if any) in parallel. The Test is evaluated before
280 each evaluation of the body Forms. When the Test is true, the Exit-Forms
281 are evaluated as a PROGN, with the result being the value of the DO. A block
282 named NIL is established around the entire expansion, allowing RETURN to be
283 used as an alternate exit mechanism."
284 (frob-do-body varlist endlist body 'let 'psetq 'do nil))
285 (defmacro-mundanely do* (varlist endlist &body body)
287 "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
288 Iteration construct. Each Var is initialized sequentially (like LET*) to the
289 value of the specified Init form. On subsequent iterations, the Vars are
290 sequentially assigned the value of the Step form (if any). The Test is
291 evaluated before each evaluation of the body Forms. When the Test is true,
292 the Exit-Forms are evaluated as a PROGN, with the result being the value
293 of the DO. A block named NIL is established around the entire expansion,
294 allowing RETURN to be used as an laternate exit mechanism."
295 (frob-do-body varlist endlist body 'let* 'setq 'do* nil))
297 ;;; DOTIMES and DOLIST could be defined more concisely using
298 ;;; destructuring macro lambda lists or DESTRUCTURING-BIND, but then
299 ;;; it'd be tricky to use them before those things were defined.
300 ;;; They're used enough times before destructuring mechanisms are
301 ;;; defined that it looks as though it's worth just implementing them
302 ;;; ASAP, at the cost of being unable to use the standard
303 ;;; destructuring mechanisms.
304 (defmacro-mundanely dotimes ((var count &optional (result nil)) &body body)
305 (cond ((numberp count)
306 `(do ((,var 0 (1+ ,var)))
307 ((>= ,var ,count) ,result)
308 (declare (type unsigned-byte ,var))
310 (t (let ((v1 (gensym)))
311 `(do ((,var 0 (1+ ,var)) (,v1 ,count))
312 ((>= ,var ,v1) ,result)
313 (declare (type unsigned-byte ,var))
316 (defmacro-mundanely dolist ((var list &optional (result nil)) &body body)
317 ;; We repeatedly bind the var instead of setting it so that we never
318 ;; have to give the var an arbitrary value such as NIL (which might
319 ;; conflict with a declaration). If there is a result form, we
320 ;; introduce a gratuitous binding of the variable to NIL without the
321 ;; declarations, then evaluate the result form in that
322 ;; environment. We spuriously reference the gratuitous variable,
323 ;; since we don't want to use IGNORABLE on what might be a special
325 (multiple-value-bind (forms decls) (parse-body body nil)
326 (let ((n-list (gensym)))
327 `(do* ((,n-list ,list (cdr ,n-list)))
334 (let ((,var (car ,n-list)))
341 (defmacro-mundanely return (&optional (value nil))
342 `(return-from nil ,value))
344 (defmacro-mundanely psetq (&rest pairs)
347 Set the variables to the values, like SETQ, except that assignments
348 happen in parallel, i.e. no assignments take place until all the
349 forms have been evaluated."
350 ;; Given the possibility of symbol-macros, we delegate to PSETF
351 ;; which knows how to deal with them, after checking that syntax is
352 ;; compatible with PSETQ.
353 (do ((pair pairs (cddr pair)))
354 ((endp pair) `(psetf ,@pairs))
355 (unless (symbolp (car pair))
356 (error 'simple-program-error
357 :format-control "variable ~S in PSETQ is not a SYMBOL"
358 :format-arguments (list (car pair))))))
360 (defmacro-mundanely lambda (&whole whole args &body body)
361 (declare (ignore args body))