;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB!INT")
+(in-package "SB!IMPL")
\f
;;;; target constants which need to appear as early as possible
;;; gencgc.c code on this value being a symbol. (This is only one of
;;; several nasty dependencies between that code and this, alas.)
;;; -- WHN 2001-08-17
-;;;
-;;; FIXME: We end up doing two DEFCONSTANT forms because (1) LispWorks
-;;; needs EVAL-WHEN wrapped around DEFCONSTANT, and (2) SBCL's
-;;; DEFCONSTANT expansion doesn't seem to behave properly inside
-;;; EVAL-WHEN, so that without this, the +EMPTY-HT-SLOT+ references in
-;;; e.g. DOHASH macroexpansions don't end up being replaced by
-;;; constant values, so that the system dies at cold init because
-;;; '+EMPTY-HT-SLOT+ isn't bound yet. It's hard to fix this properly
-;;; until SBCL's EVAL-WHEN is fixed, which is waiting for the IR1
-;;; interpreter to go away, which is waiting for sbcl-0.7.x..
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant +empty-ht-slot+ '%empty-ht-slot%))
+ (def!constant +empty-ht-slot+ '%empty-ht-slot%))
;;; We shouldn't need this mess now that EVAL-WHEN works.
-#+nil (defconstant +empty-ht-slot+ '#.+empty-ht-slot+) ; egads.. See FIXME above.
+
;;; KLUDGE: Using a private symbol still leaves us vulnerable to users
;;; getting nonconforming behavior by messing around with
;;; DO-ALL-SYMBOLS. That seems like a fairly obscure problem, so for
\f
;;;; DO-related stuff which needs to be visible on the cross-compilation host
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun frob-do-body (varlist endlist decls-and-code bind step name block)
(let* ((r-inits nil) ; accumulator for reversed list
(r-steps nil) ; accumulator for reversed list
(t (illegal-varlist)))))
(t (illegal-varlist)))))
;; Construct the new form.
- (multiple-value-bind (code decls) (parse-body decls-and-code nil)
+ (multiple-value-bind (code decls)
+ (parse-body decls-and-code :doc-string-allowed nil)
`(block ,block
(,bind ,(nreverse r-inits)
,@decls
(tagbody
- (go ,label-2)
- ,label-1
- ,@code
- (,step ,@(nreverse r-steps))
- ,label-2
- (unless ,(first endlist) (go ,label-1))
- (return-from ,block (progn ,@(rest endlist))))))))))
+ (go ,label-2)
+ ,label-1
+ (tagbody ,@code)
+ (,step ,@(nreverse r-steps))
+ ,label-2
+ (unless ,(first endlist) (go ,label-1))
+ (return-from ,block (progn ,@(rest endlist))))))))))
;;; This is like DO, except it has no implicit NIL block. Each VAR is
;;; initialized in parallel to the value of the specified INIT form.
(defmacro do-anonymous (varlist endlist &rest body)
(frob-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
\f
+;;;; GENSYM tricks
+
+;;; Automate an idiom often found in macros:
+;;; (LET ((FOO (GENSYM "FOO"))
+;;; (MAX-INDEX (GENSYM "MAX-INDEX-")))
+;;; ...)
+;;;
+;;; "Good notation eliminates thought." -- Eric Siggia
+;;;
+;;; Incidentally, this is essentially the same operator which
+;;; _On Lisp_ calls WITH-GENSYMS.
+(defmacro with-unique-names (symbols &body body)
+ `(let ,(mapcar (lambda (symbol)
+ (let* ((symbol-name (symbol-name symbol))
+ (stem (if (every #'alpha-char-p symbol-name)
+ symbol-name
+ (concatenate 'string symbol-name "-"))))
+ `(,symbol (gensym ,stem))))
+ symbols)
+ ,@body))
+
+;;; Return a list of N gensyms. (This is a common suboperation in
+;;; macros and other code-manipulating code.)
+(declaim (ftype (function (index) list) make-gensym-list))
+(defun make-gensym-list (n)
+ (loop repeat n collect (gensym)))
+\f
;;;; miscellany
+;;; Lots of code wants to get to the KEYWORD package or the
+;;; COMMON-LISP package without a lot of fuss, so we cache them in
+;;; variables. TO DO: How much does this actually buy us? It sounds
+;;; sensible, but I don't know for sure that it saves space or time..
+;;; -- WHN 19990521
+;;;
+;;; (The initialization forms here only matter on the cross-compilation
+;;; host; In the target SBCL, these variables are set in cold init.)
+(declaim (type package *cl-package* *keyword-package*))
+(defvar *cl-package* (find-package "COMMON-LISP"))
+(defvar *keyword-package* (find-package "KEYWORD"))
+
;;; Concatenate together the names of some strings and symbols,
;;; producing a symbol in the current package.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun symbolicate (&rest things)
- (values (intern (apply #'concatenate
- 'string
- (mapcar #'string things))))))
+ (let* ((length (reduce #'+ things
+ :key (lambda (x) (length (string x)))))
+ (name (make-array length :element-type 'character)))
+ (let ((index 0))
+ (dolist (thing things (values (intern name)))
+ (let* ((x (string thing))
+ (len (length x)))
+ (replace name x :start1 index)
+ (incf index len)))))))
;;; like SYMBOLICATE, but producing keywords
(defun keywordicate (&rest things)
(if (consp id)
(values (car id) (cdr id))
(values id nil))
- (push `(defconstant ,(symbolicate prefix root suffix)
+ (push `(def!constant ,(symbolicate prefix root suffix)
,(+ start (* step index))
,@docs)
results)))
;;; need to avoid runtime indirection through a symbol, you might be
;;; able to do something with LOAD-TIME-VALUE or MAKE-LOAD-FORM.
(defmacro defconstant-eqx (symbol expr eqx &optional doc)
- `(defconstant ,symbol
+ `(def!constant ,symbol
(%defconstant-eqx-value ',symbol ,expr ,eqx)
,@(when doc (list doc))))
(defun %defconstant-eqx-value (symbol expr eqx)
+ (declare (type function eqx))
(flet ((bummer (explanation)
(error "~@<bad DEFCONSTANT-EQX ~S ~2I~_~S: ~2I~_~A ~S~:>"
symbol
(bummer "already bound as a different constant value"))
(t
(symbol-value symbol)))))
+\f
+;;; a helper function for various macros which expect clauses of a
+;;; given length, etc.
+;;;
+;;; Return true if X is a proper list whose length is between MIN and
+;;; MAX (inclusive).
+(defun proper-list-of-length-p (x min &optional (max min))
+ ;; FIXME: This implementation will hang on circular list
+ ;; structure. Since this is an error-checking utility, i.e. its
+ ;; job is to deal with screwed-up input, it'd be good style to fix
+ ;; it so that it can deal with circular list structure.
+ (cond ((minusp max) nil)
+ ((null x) (zerop min))
+ ((consp x)
+ (and (plusp max)
+ (proper-list-of-length-p (cdr x)
+ (if (plusp (1- min))
+ (1- min)
+ 0)
+ (1- max))))
+ (t nil)))
+
+;;; Helpers for defining error-signalling NOP's for "not supported
+;;; here" operations.
+(defmacro define-unsupported-fun (name &optional
+ (doc "Unsupported on this platform.")
+ (control
+ "~S is unsupported on this platform ~
+ (OS, CPU, whatever)."
+ controlp)
+ arguments)
+ `(defun ,name (&rest args)
+ ,doc
+ (declare (ignore args))
+ (error 'unsupported-operator
+ :format-control ,control
+ :format-arguments (if ,controlp ',arguments (list ',name)))))