Silence notes about being specialised EQ templates on x86oids
[sbcl.git] / src / code / macros.lisp
1 ;;;; lots of basic macros for the target SBCL
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!IMPL")
13 \f
14 ;;;; ASSERT and CHECK-TYPE
15
16 ;;; ASSERT is written this way, to call ASSERT-ERROR, because of how
17 ;;; closures are compiled. RESTART-CASE has forms with closures that
18 ;;; the compiler causes to be generated at the top of any function
19 ;;; using RESTART-CASE, regardless of whether they are needed. Thus if
20 ;;; we just wrapped a RESTART-CASE around the call to ERROR, we'd have
21 ;;; to do a significant amount of work at runtime allocating and
22 ;;; deallocating the closures regardless of whether they were ever
23 ;;; needed.
24 ;;;
25 ;;; ASSERT-ERROR isn't defined until a later file because it uses the
26 ;;; macro RESTART-CASE, which isn't defined until a later file.
27 (defmacro-mundanely assert (test-form &optional places datum &rest arguments
28                             &environment env)
29   #!+sb-doc
30   "Signals an error if the value of TEST-FORM is NIL. Returns NIL.
31
32    Optional DATUM and ARGUMENTS can be used to change the signaled
33    error condition and are interpreted as in (APPLY #'ERROR DATUM
34    ARGUMENTS).
35
36    Continuing from the signaled error using the CONTINUE restart will
37    allow the user to alter the values of the SETFable locations
38    specified in PLACES and then start over with TEST-FORM.
39
40    If TEST-FORM is of the form
41
42      (FUNCTION ARG*)
43
44    where FUNCTION is a function (but not a special operator like
45    CL:OR, CL:AND, etc.) the results of evaluating the ARGs will be
46    included in the error report if the assertion fails."
47   (collect ((bindings) (infos))
48     (let ((new-test
49             (flet ((process-place (place)
50                      (if (sb!xc:constantp place env)
51                          place
52                          (with-unique-names (temp)
53                            (bindings `(,temp ,place))
54                            (infos `(list ',place ,temp))
55                            temp))))
56               (cond
57                 ;; TEST-FORM looks like a function call. We do not
58                 ;; attempt this if TEST-FORM is the application of a
59                 ;; special operator because of argument evaluation
60                 ;; order issues.
61                 ((and (typep test-form '(cons symbol list))
62                       (eq (info :function :kind (first test-form)) :function))
63                  (let ((name (first test-form))
64                        (args (mapcar #'process-place (rest test-form))))
65                    `(,name ,@args)))
66                 ;; For all other cases, just evaluate TEST-FORM and do
67                 ;; not report any details if the assertion fails.
68                 (t
69                  test-form)))))
70       ;; If TEST-FORM, potentially using values from BINDINGS, does not
71       ;; hold, enter a loop which reports the assertion error,
72       ;; potentially changes PLACES, and retries TEST-FORM.
73       `(tagbody
74         :try
75           (let ,(bindings)
76             (when ,new-test
77               (go :done))
78             (assert-error ',test-form (list ,@(infos))
79                           ',places ,datum ,@arguments))
80           ,@(mapcar (lambda (place)
81                       `(setf ,place (assert-prompt ',place ,place)))
82                     places)
83           (go :try)
84         :done))))
85
86 (defun assert-prompt (name value)
87   (cond ((y-or-n-p "The old value of ~S is ~S.~
88                     ~%Do you want to supply a new value? "
89                    name value)
90          (format *query-io* "~&Type a form to be evaluated:~%")
91          (flet ((read-it () (eval (read *query-io*))))
92            (if (symbolp name) ;help user debug lexical variables
93                (progv (list name) (list value) (read-it))
94                (read-it))))
95         (t value)))
96
97 ;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because
98 ;;; of how closures are compiled. RESTART-CASE has forms with closures
99 ;;; that the compiler causes to be generated at the top of any
100 ;;; function using RESTART-CASE, regardless of whether they are
101 ;;; needed. Because it would be nice if CHECK-TYPE were cheap to use,
102 ;;; and some things (e.g., READ-CHAR) can't afford this excessive
103 ;;; consing, we bend backwards a little.
104 ;;;
105 ;;; CHECK-TYPE-ERROR isn't defined until a later file because it uses
106 ;;; the macro RESTART-CASE, which isn't defined until a later file.
107 (defmacro-mundanely check-type (place type &optional type-string
108                                 &environment env)
109   #!+sb-doc
110   "Signal a restartable error of type TYPE-ERROR if the value of PLACE
111 is not of the specified type. If an error is signalled and the restart
112 is used to return, this can only return if the STORE-VALUE restart is
113 invoked. In that case it will store into PLACE and start over."
114   ;; Detect a common user-error.
115   (when (and (consp type) (eq 'quote (car type)))
116     (error 'simple-reference-error
117            :format-control "Quoted type specifier in ~S: ~S"
118            :format-arguments (list 'check-type type)
119            :references (list '(:ansi-cl :macro check-type))))
120   ;; KLUDGE: We use a simpler form of expansion if PLACE is just a
121   ;; variable to work around Python's blind spot in type derivation.
122   ;; For more complex places getting the type derived should not
123   ;; matter so much anyhow.
124   (let ((expanded (%macroexpand place env)))
125     (if (symbolp expanded)
126         `(do ()
127              ((typep ,place ',type))
128           (setf ,place (check-type-error ',place ,place ',type ,type-string)))
129         (let ((value (gensym)))
130           `(do ((,value ,place ,place))
131                ((typep ,value ',type))
132             (setf ,place
133                   (check-type-error ',place ,value ',type ,type-string)))))))
134 \f
135 ;;;; DEFINE-SYMBOL-MACRO
136
137 (defmacro-mundanely define-symbol-macro (name expansion)
138   `(eval-when (:compile-toplevel :load-toplevel :execute)
139     (sb!c::%define-symbol-macro ',name ',expansion (sb!c:source-location))))
140
141 (defun sb!c::%define-symbol-macro (name expansion source-location)
142   (unless (symbolp name)
143     (error 'simple-type-error :datum name :expected-type 'symbol
144            :format-control "Symbol macro name is not a symbol: ~S."
145            :format-arguments (list name)))
146   (with-single-package-locked-error
147       (:symbol name "defining ~A as a symbol-macro"))
148   (sb!c:with-source-location (source-location)
149     (setf (info :source-location :symbol-macro name) source-location))
150   (let ((kind (info :variable :kind name)))
151     (ecase kind
152      ((:macro :unknown)
153       (setf (info :variable :kind name) :macro)
154       (setf (info :variable :macro-expansion name) expansion))
155      ((:special :global)
156       (error 'simple-program-error
157              :format-control "Symbol macro name already declared ~A: ~S."
158              :format-arguments (list kind name)))
159      (:constant
160       (error 'simple-program-error
161              :format-control "Symbol macro name already defined as a constant: ~S."
162              :format-arguments (list name)))))
163   name)
164 \f
165 ;;;; DEFINE-COMPILER-MACRO
166
167 (defmacro-mundanely define-compiler-macro (name lambda-list &body body)
168   #!+sb-doc
169   "Define a compiler-macro for NAME."
170   (legal-fun-name-or-type-error name)
171   (when (and (symbolp name) (special-operator-p name))
172     (error 'simple-program-error
173            :format-control "cannot define a compiler-macro for a special operator: ~S"
174            :format-arguments (list name)))
175   (with-unique-names (whole environment)
176     (multiple-value-bind (body local-decs doc)
177         (parse-defmacro lambda-list whole body name 'define-compiler-macro
178                         :environment environment)
179       (let ((def `(lambda (,whole ,environment)
180                     ,@local-decs
181                     ,body))
182             (debug-name (sb!c::debug-name 'compiler-macro-function name)))
183         `(eval-when (:compile-toplevel :load-toplevel :execute)
184            (sb!c::%define-compiler-macro ',name
185                                          #',def
186                                          ',lambda-list
187                                          ,doc
188                                          ',debug-name))))))
189
190 ;;; FIXME: This will look remarkably similar to those who have already
191 ;;; seen the code for %DEFMACRO in src/code/defmacro.lisp.  Various
192 ;;; bits of logic should be shared (notably arglist setting).
193 (macrolet
194     ((def (times set-p)
195          `(eval-when (,@times)
196            (defun sb!c::%define-compiler-macro
197                (name definition lambda-list doc debug-name)
198              ,@(unless set-p
199                  '((declare (ignore lambda-list debug-name))))
200              ;; FIXME: warn about incompatible lambda list with
201              ;; respect to parent function?
202              (setf (sb!xc:compiler-macro-function name) definition)
203              ,(when set-p
204                     `(setf (%fun-doc definition) doc
205                            (%fun-lambda-list definition) lambda-list
206                            (%fun-name definition) debug-name))
207              name))))
208   (progn
209     (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
210     #-sb-xc (def (:compile-toplevel) nil)))
211 \f
212 ;;;; CASE, TYPECASE, and friends
213
214 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
215
216 ;;; Make this a full warning during SBCL build.
217 (define-condition duplicate-case-key-warning (#-sb-xc-host style-warning #+sb-xc-host warning)
218   ((key :initarg :key
219         :reader case-warning-key)
220    (case-kind :initarg :case-kind
221               :reader case-warning-case-kind)
222    (occurrences :initarg :occurrences
223                 :type list
224                 :reader duplicate-case-key-warning-occurrences))
225   (:report
226     (lambda (condition stream)
227       (format stream
228         "Duplicate key ~S in ~S form, ~
229          occurring in~{~#[~; and~]~{ the ~:R clause:~%~<  ~S~:>~}~^,~}."
230         (case-warning-key condition)
231         (case-warning-case-kind condition)
232         (duplicate-case-key-warning-occurrences condition)))))
233
234 ;;; CASE-BODY returns code for all the standard "case" macros. NAME is
235 ;;; the macro name, and KEYFORM is the thing to case on. MULTI-P
236 ;;; indicates whether a branch may fire off a list of keys; otherwise,
237 ;;; a key that is a list is interpreted in some way as a single key.
238 ;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key
239 ;;; for a given branch; otherwise, TEST is applied to the value of
240 ;;; KEYFORM and the entire first element, instead of each part, of the
241 ;;; case branch. When ERRORP, no OTHERWISE-CLAUSEs are recognized,
242 ;;; and an ERROR form is generated where control falls off the end
243 ;;; of the ordinary clauses. When PROCEEDP, it is an error to
244 ;;; omit ERRORP, and the ERROR form generated is executed within a
245 ;;; RESTART-CASE allowing KEYFORM to be set and retested.
246 (defun case-body (name keyform cases multi-p test errorp proceedp needcasesp)
247   (unless (or cases (not needcasesp))
248     (warn "no clauses in ~S" name))
249   (let ((keyform-value (gensym))
250         (clauses ())
251         (keys ())
252         (keys-seen (make-hash-table :test #'eql)))
253     (do* ((cases cases (cdr cases))
254           (case (car cases) (car cases))
255           (case-position 1 (1+ case-position)))
256          ((null cases) nil)
257       (flet ((check-clause (case-keys)
258                (loop for k in case-keys
259                      for existing = (gethash k keys-seen)
260                      do (when existing
261                           (let ((sb!c::*current-path*
262                                  (when (boundp 'sb!c::*source-paths*)
263                                    (or (sb!c::get-source-path case)
264                                        sb!c::*current-path*))))
265                             (warn 'duplicate-case-key-warning
266                                   :key k
267                                   :case-kind name
268                                   :occurrences `(,existing (,case-position (,case)))))))
269                (let ((record (list case-position (list case))))
270                  (dolist (k case-keys)
271                    (setf (gethash k keys-seen) record)))))
272         (unless (list-of-length-at-least-p case 1)
273           (error "~S -- bad clause in ~S" case name))
274         (destructuring-bind (keyoid &rest forms) case
275           (cond (;; an OTHERWISE-CLAUSE
276                  ;;
277                  ;; By the way... The old code here tried gave
278                  ;; STYLE-WARNINGs for normal-clauses which looked as
279                  ;; though they might've been intended to be
280                  ;; otherwise-clauses. As Tony Martinez reported on
281                  ;; sbcl-devel 2004-11-09 there are sometimes good
282                  ;; reasons to write clauses like that; and as I noticed
283                  ;; when trying to understand the old code so I could
284                  ;; understand his patch, trying to guess which clauses
285                  ;; don't have good reasons is fundamentally kind of a
286                  ;; mess. SBCL does issue style warnings rather
287                  ;; enthusiastically, and I have often justified that by
288                  ;; arguing that we're doing that to detect issues which
289                  ;; are tedious for programmers to detect for by
290                  ;; proofreading (like small typoes in long symbol
291                  ;; names, or duplicate function definitions in large
292                  ;; files). This doesn't seem to be an issue like that,
293                  ;; and I can't think of a comparably good justification
294                  ;; for giving STYLE-WARNINGs for legal code here, so
295                  ;; now we just hope the programmer knows what he's
296                  ;; doing. -- WHN 2004-11-20
297                  (and (not errorp) ; possible only in CASE or TYPECASE,
298                                    ; not in [EC]CASE or [EC]TYPECASE
299                       (memq keyoid '(t otherwise))
300                       (null (cdr cases)))
301                  (push `(t nil ,@forms) clauses))
302                 ((and multi-p (listp keyoid))
303                  (setf keys (append keyoid keys))
304                  (check-clause keyoid)
305                  (push `((or ,@(mapcar (lambda (key)
306                                          `(,test ,keyform-value ',key))
307                                        keyoid))
308                          nil
309                          ,@forms)
310                        clauses))
311                 (t
312                  (when (and (eq name 'case)
313                             (cdr cases)
314                             (memq keyoid '(t otherwise)))
315                    (error 'simple-reference-error
316                           :format-control
317                           "~@<~IBad ~S clause:~:@_  ~S~:@_~S allowed as the key ~
318                            designator only in the final otherwise-clause, not in a ~
319                            normal-clause. Use (~S) instead, or move the clause the ~
320                            correct position.~:@>"
321                           :format-arguments (list 'case case keyoid keyoid)
322                           :references `((:ansi-cl :macro case))))
323                  (push keyoid keys)
324                  (check-clause (list keyoid))
325                  (push `((,test ,keyform-value ',keyoid)
326                          nil
327                          ,@forms)
328                        clauses))))))
329     (case-body-aux name keyform keyform-value clauses keys errorp proceedp
330                    `(,(if multi-p 'member 'or) ,@keys))))
331
332 ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled
333 ;;; all the cases. Note: it is not necessary that the resulting code
334 ;;; signal case-failure conditions, but that's what KMP's prototype
335 ;;; code did. We call CASE-BODY-ERROR, because of how closures are
336 ;;; compiled. RESTART-CASE has forms with closures that the compiler
337 ;;; causes to be generated at the top of any function using the case
338 ;;; macros, regardless of whether they are needed.
339 ;;;
340 ;;; The CASE-BODY-ERROR function is defined later, when the
341 ;;; RESTART-CASE macro has been defined.
342 (defun case-body-aux (name keyform keyform-value clauses keys
343                       errorp proceedp expected-type)
344   (if proceedp
345       (let ((block (gensym))
346             (again (gensym)))
347         `(let ((,keyform-value ,keyform))
348            (block ,block
349              (tagbody
350               ,again
351               (return-from
352                ,block
353                (cond ,@(nreverse clauses)
354                      (t
355                       (setf ,keyform-value
356                             (setf ,keyform
357                                   (case-body-error
358                                    ',name ',keyform ,keyform-value
359                                    ',expected-type ',keys)))
360                       (go ,again))))))))
361       `(let ((,keyform-value ,keyform))
362          (declare (ignorable ,keyform-value)) ; e.g. (CASE KEY (T))
363          (cond
364           ,@(nreverse clauses)
365           ,@(if errorp
366                 `((t (case-failure ',name ,keyform-value ',keys))))))))
367 ) ; EVAL-WHEN
368
369 (defmacro-mundanely case (keyform &body cases)
370   #!+sb-doc
371   "CASE Keyform {({(Key*) | Key} Form*)}*
372   Evaluates the Forms in the first clause with a Key EQL to the value of
373   Keyform. If a singleton key is T then the clause is a default clause."
374   (case-body 'case keyform cases t 'eql nil nil nil))
375
376 (defmacro-mundanely ccase (keyform &body cases)
377   #!+sb-doc
378   "CCASE Keyform {({(Key*) | Key} Form*)}*
379   Evaluates the Forms in the first clause with a Key EQL to the value of
380   Keyform. If none of the keys matches then a correctable error is
381   signalled."
382   (case-body 'ccase keyform cases t 'eql t t t))
383
384 (defmacro-mundanely ecase (keyform &body cases)
385   #!+sb-doc
386   "ECASE Keyform {({(Key*) | Key} Form*)}*
387   Evaluates the Forms in the first clause with a Key EQL to the value of
388   Keyform. If none of the keys matches then an error is signalled."
389   (case-body 'ecase keyform cases t 'eql t nil t))
390
391 (defmacro-mundanely typecase (keyform &body cases)
392   #!+sb-doc
393   "TYPECASE Keyform {(Type Form*)}*
394   Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
395   is true."
396   (case-body 'typecase keyform cases nil 'typep nil nil nil))
397
398 (defmacro-mundanely ctypecase (keyform &body cases)
399   #!+sb-doc
400   "CTYPECASE Keyform {(Type Form*)}*
401   Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
402   is true. If no form is satisfied then a correctable error is signalled."
403   (case-body 'ctypecase keyform cases nil 'typep t t t))
404
405 (defmacro-mundanely etypecase (keyform &body cases)
406   #!+sb-doc
407   "ETYPECASE Keyform {(Type Form*)}*
408   Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
409   is true. If no form is satisfied then an error is signalled."
410   (case-body 'etypecase keyform cases nil 'typep t nil t))
411 \f
412 ;;;; WITH-FOO i/o-related macros
413
414 (defmacro-mundanely with-open-stream ((var stream) &body forms-decls)
415   (multiple-value-bind (forms decls)
416       (parse-body forms-decls :doc-string-allowed nil)
417     (let ((abortp (gensym)))
418       `(let ((,var ,stream)
419              (,abortp t))
420          ,@decls
421          (unwind-protect
422              (multiple-value-prog1
423               (progn ,@forms)
424               (setq ,abortp nil))
425            (when ,var
426              (close ,var :abort ,abortp)))))))
427
428 (defmacro-mundanely with-open-file ((stream filespec &rest options)
429                                     &body body)
430   `(with-open-stream (,stream (open ,filespec ,@options))
431      ,@body))
432
433 (defmacro-mundanely with-input-from-string ((var string &key index start end)
434                                             &body forms-decls)
435   (multiple-value-bind (forms decls)
436       (parse-body forms-decls :doc-string-allowed nil)
437     ;; The ONCE-ONLY inhibits compiler note for unreachable code when
438     ;; END is true.
439     (once-only ((string string))
440       `(let ((,var
441               ,(cond ((null end)
442                       `(make-string-input-stream ,string ,(or start 0)))
443                      ((symbolp end)
444                       `(if ,end
445                            (make-string-input-stream ,string
446                                                      ,(or start 0)
447                                                      ,end)
448                            (make-string-input-stream ,string
449                                                      ,(or start 0))))
450                      (t
451                       `(make-string-input-stream ,string
452                                                  ,(or start 0)
453                                                  ,end)))))
454          ,@decls
455          (multiple-value-prog1
456              (unwind-protect
457                   (progn ,@forms)
458                (close ,var))
459            ,@(when index
460                `((setf ,index (string-input-stream-current ,var)))))))))
461
462 (defmacro-mundanely with-output-to-string
463     ((var &optional string &key (element-type ''character))
464      &body forms-decls)
465   (multiple-value-bind (forms decls)
466       (parse-body forms-decls :doc-string-allowed nil)
467     (if string
468         (let ((element-type-var (gensym)))
469           `(let ((,var (make-fill-pointer-output-stream ,string))
470                  ;; ELEMENT-TYPE isn't currently used for anything
471                  ;; (see FILL-POINTER-OUTPUT-STREAM FIXME in stream.lisp),
472                  ;; but it still has to be evaluated for side-effects.
473                  (,element-type-var ,element-type))
474             (declare (ignore ,element-type-var))
475             ,@decls
476             (unwind-protect
477                  (progn ,@forms)
478               (close ,var))))
479       `(let ((,var (make-string-output-stream :element-type ,element-type)))
480          ,@decls
481          (unwind-protect
482              (progn ,@forms)
483            (close ,var))
484          (get-output-stream-string ,var)))))
485 \f
486 ;;;; miscellaneous macros
487
488 (defmacro-mundanely nth-value (n form)
489   #!+sb-doc
490   "Evaluate FORM and return the Nth value (zero based). This involves no
491   consing when N is a trivial constant integer."
492   ;; FIXME: The above is true, if slightly misleading.  The
493   ;; MULTIPLE-VALUE-BIND idiom [ as opposed to MULTIPLE-VALUE-CALL
494   ;; (LAMBDA (&REST VALUES) (NTH N VALUES)) ] does indeed not cons at
495   ;; runtime.  However, for large N (say N = 200), COMPILE on such a
496   ;; form will take longer than can be described as adequate, as the
497   ;; optional dispatch mechanism for the M-V-B gets increasingly
498   ;; hairy.
499   (if (integerp n)
500       (let ((dummy-list (make-gensym-list n))
501             (keeper (sb!xc:gensym "KEEPER")))
502         `(multiple-value-bind (,@dummy-list ,keeper) ,form
503            (declare (ignore ,@dummy-list))
504            ,keeper))
505       (once-only ((n n))
506         `(case (the fixnum ,n)
507            (0 (nth-value 0 ,form))
508            (1 (nth-value 1 ,form))
509            (2 (nth-value 2 ,form))
510            (t (nth (the fixnum ,n) (multiple-value-list ,form)))))))
511
512 (defmacro-mundanely declaim (&rest specs)
513   #!+sb-doc
514   "DECLAIM Declaration*
515   Do a declaration or declarations for the global environment."
516   `(eval-when (:compile-toplevel :load-toplevel :execute)
517      ,@(mapcar (lambda (spec) `(sb!xc:proclaim ',spec))
518                specs)))
519
520 (defmacro-mundanely print-unreadable-object ((object stream &key type identity)
521                                              &body body)
522   "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally
523   with object-type prefix and object-identity suffix, and executing the
524   code in BODY to provide possible further output."
525   `(%print-unreadable-object ,object ,stream ,type ,identity
526                              ,(if body
527                                   `(lambda () ,@body)
528                                   nil)))
529
530 (defmacro-mundanely ignore-errors (&rest forms)
531   #!+sb-doc
532   "Execute FORMS handling ERROR conditions, returning the result of the last
533   form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
534   `(handler-case (progn ,@forms)
535      (error (condition) (values nil condition))))