0.6.8.9:
[sbcl.git] / src / code / primordial-extensions.lisp
1 ;;;; various user-level definitions which need to be done particularly
2 ;;;; early
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!INT")
14
15 \f
16 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
17
18 (eval-when (:compile-toplevel :load-toplevel :execute)
19   (defun do-do-body (varlist endlist decls-and-code bind step name block)
20     (let* ((r-inits nil) ; accumulator for reversed list
21            (r-steps nil) ; accumulator for reversed list
22            (label-1 (gensym))
23            (label-2 (gensym)))
24       ;; Check for illegal old-style DO.
25       (when (or (not (listp varlist)) (atom endlist))
26         (error "Ill-formed ~S -- possibly illegal old style DO?" name))
27       ;; Parse VARLIST to get R-INITS and R-STEPS.
28       (dolist (v varlist)
29         (flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be defined
30                ;; in terms of CL:SETF, and CL:SETF can be defined in terms of
31                ;; CL:DO, and CL:DO can be defined in terms of the current
32                ;; function.)
33                (push-on-r-inits (x)
34                  (setq r-inits (cons x r-inits)))
35                ;; common error-handling
36                (illegal-varlist ()
37                  (error "~S is an illegal form for a ~S varlist." v name)))
38           (cond ((symbolp v) (push-on-r-inits v))
39                 ((listp v)
40                  (unless (symbolp (first v))
41                    (error "~S step variable is not a symbol: ~S"
42                           name
43                           (first v)))
44                  (let ((lv (length v)))
45                    ;; (We avoid using CL:CASE here so that CL:CASE can be
46                    ;; defined in terms of CL:SETF, and CL:SETF can be defined
47                    ;; in terms of CL:DO, and CL:DO can be defined in terms of
48                    ;; the current function.)
49                    (cond ((= lv 1)
50                           (push-on-r-inits (first v)))
51                          ((= lv 2)
52                           (push-on-r-inits v))
53                          ((= lv 3)
54                           (push-on-r-inits (list (first v) (second v)))
55                           (setq r-steps (list* (third v) (first v) r-steps)))
56                          (t (illegal-varlist)))))
57                 (t (illegal-varlist)))))
58       ;; Construct the new form.
59       (multiple-value-bind (code decls) (parse-body decls-and-code nil)
60         `(block ,block
61            (,bind ,(nreverse r-inits)
62                   ,@decls
63                   (tagbody
64                    (go ,label-2)
65                    ,label-1
66                    ,@code
67                    (,step ,@(nreverse r-steps))
68                    ,label-2
69                    (unless ,(first endlist) (go ,label-1))
70                    (return-from ,block (progn ,@(rest endlist))))))))))
71
72 (defmacro do-anonymous (varlist endlist &rest body)
73   #!+sb-doc
74   "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
75   Like DO, but has no implicit NIL block. Each Var is initialized in parallel
76   to the value of the specified Init form. On subsequent iterations, the Vars
77   are assigned the value of the Step form (if any) in parallel. The Test is
78   evaluated before each evaluation of the body Forms. When the Test is true,
79   the Exit-Forms are evaluated as a PROGN, with the result being the value
80   of the DO."
81   (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
82 \f
83 ;;;; miscellany
84
85 ;;; Concatenate together the names of some strings and symbols,
86 ;;; producing a symbol in the current package.
87 (defun symbolicate (&rest things)
88   (values (intern (apply #'concatenate
89                          'string
90                          (mapcar #'string things)))))
91
92 ;;; like SYMBOLICATE, but producing keywords
93 (defun keywordicate (&rest things)
94   (let ((*package* *keyword-package*))
95     (apply #'symbolicate things)))
96
97 ;;; Give names to elements of a numeric sequence.
98 (defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
99                    &rest identifiers)
100   (let ((results nil)
101         (index 0)
102         (start (eval start))
103         (step (eval step)))
104     (dolist (id identifiers)
105       (when id
106         (multiple-value-bind (root docs)
107             (if (consp id)
108                 (values (car id) (cdr id))
109                 (values id nil))
110           ;; (This could be SYMBOLICATE, except that due to
111           ;; bogobootstrapping issues SYMBOLICATE isn't defined yet.)
112           (push `(defconstant ,(symbolicate prefix root suffix)
113                    ,(+ start (* step index))
114                    ,@docs)
115                 results)))
116       (incf index))
117     `(progn
118        ,@(nreverse results))))
119
120 ;;; generalization of DEFCONSTANT to values which are the same not
121 ;;; under EQL but under e.g. EQUAL or EQUALP
122 ;;;
123 ;;; DEFCONSTANT-EQX is to be used instead of DEFCONSTANT for values
124 ;;; which are appropriately compared using the function given by the
125 ;;; EQX argument instead of EQL.
126 ;;;
127 ;;; Note: Be careful when using this macro, since it's easy to
128 ;;; unintentionally pessimize your code. A good time to use this macro
129 ;;; is when the values defined will be fed into optimization
130 ;;; transforms and never actually appear in the generated code; this
131 ;;; is especially common when defining BYTE expressions. Unintentional
132 ;;; pessimization can result when the values defined by this macro are
133 ;;; actually used in generated code: because of the way that the
134 ;;; dump/load system works, you'll typically get one copy of consed
135 ;;; structure for each object file which contains code referring to
136 ;;; the value, plus perhaps one more copy bound to the SYMBOL-VALUE of
137 ;;; the constant. If you don't want that to happen, you should
138 ;;; probably use DEFPARAMETER instead.
139 (defmacro defconstant-eqx (symbol expr eqx &optional doc)
140   (let ((expr-tmp (gensym "EXPR-TMP-")))
141     `(progn
142        ;; When we're building the cross-compiler, and in most
143        ;; situations even when we're running the cross-compiler,
144        ;; all we need is a nice portable definition in terms of the
145        ;; ANSI Common Lisp operations.
146        (eval-when (:compile-toplevel :load-toplevel :execute)
147          (let ((,expr-tmp ,expr))
148            (unless (and (boundp ',symbol)
149                         (constantp ',symbol)
150                         (funcall ,eqx (symbol-value ',symbol) ,expr-tmp))
151              (defconstant ,symbol ,expr ,@(when doc `(,doc))))))
152        ;; The #+SB-XC :COMPILE-TOPLEVEL situation is special, since we
153        ;; want to define the symbol not just in the cross-compilation
154        ;; host Lisp (which was handled above) but also in the
155        ;; cross-compiler (which we will handle now).
156        ;;
157        ;; KLUDGE: It would probably be possible to do this fairly
158        ;; cleanly, in a way parallel to the code above, if we had
159        ;; SB!XC:FOO versions of all the primitives CL:FOO used above
160        ;; (e.g. SB!XC:BOUNDP, SB!XC:SYMBOL-VALUE, and
161        ;; SB!XC:DEFCONSTANT), and took care to call them. But right
162        ;; now we just hack around in the guts of the cross-compiler
163        ;; instead. -- WHN 2000-11-03
164        #+sb-xc
165        (eval-when (:compile-toplevel)
166          (let ((,expr-tmp ,expr))
167            (unless (and (eql (info :variable :kind ',symbol) :constant)
168                         (funcall ,eqx
169                                  (info :variable :constant-value ',symbol)
170                                  ,expr-tmp))
171              (sb!c::%defconstant ',symbol ,expr-tmp ,doc)))))))