\f
;;;; GENSYM tricks
-;;; GENSYM variant for easier debugging and better backtraces: append
-;;; the closest enclosing non-nil block name to the provided stem.
-(defun block-gensym (&optional (name "G") (env (when (boundp 'sb!c::*lexenv*)
- (symbol-value 'sb!c::*lexenv*))))
- (let ((block-name (when env
- (car (find-if #'car (sb!c::lexenv-blocks env))))))
- (if block-name
- (sb!xc:gensym (format nil "~A[~A]" name block-name))
- (sb!xc:gensym name))))
-
;;; Compile a version of BODY for all TYPES, and dispatch to the
;;; correct one based on the value of VAR. This was originally used
;;; only for strings, hence the name. Renaming it to something more
(declare (inline ,fun))
(etypecase ,var
,@(loop for type in types
- collect `(,type (,fun (the ,type ,var))))))))
+ ;; TRULY-THE allows transforms to take advantage of the type
+ ;; information without need for constraint propagation.
+ collect `(,type (,fun (truly-the ,type ,var))))))))
;;; Automate an idiom often found in macros:
;;; (LET ((FOO (GENSYM "FOO"))
(stem (if (every #'alpha-char-p symbol-name)
symbol-name
(concatenate 'string symbol-name "-"))))
- `(,symbol (block-gensym ,stem))))
+ `(,symbol (sb!xc: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 (block-gensym)))
+(declaim (ftype (function (index &optional t) (values list &optional))
+ make-gensym-list))
+(defun make-gensym-list (n &optional name)
+ (when (eq t name)
+ (break))
+ (if name
+ (loop repeat n collect (sb!xc:gensym (string name)))
+ (loop repeat n collect (sb!xc:gensym))))
\f
;;;; miscellany
(replace name x :start1 index)
(incf index len)))))))
+(defun gensymify (x)
+ (if (symbolp x)
+ (sb!xc:gensym (symbol-name x))
+ (sb!xc:gensym)))
+
;;; like SYMBOLICATE, but producing keywords
(defun keywordicate (&rest things)
(let ((*package* *keyword-package*))
;; but it will immediately lead to undefined to behavior,
;; since almost any operation on a deleted package is
;; undefined.
- (package-name maybe-package))
+ #-sb-xc-host
+ (package-%name maybe-package))
maybe-package)
(t
;; We're in the undefined behavior zone. First, munge the
dfd))
;;; Give names to elements of a numeric sequence.
-(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
+(defmacro defenum ((&key (start 0) (step 1))
&rest identifiers)
(let ((results nil)
(index 0)
(step (eval step)))
(dolist (id identifiers)
(when id
- (multiple-value-bind (root docs)
+ (multiple-value-bind (sym docs)
(if (consp id)
(values (car id) (cdr id))
(values id nil))
- (push `(def!constant ,(symbolicate prefix root suffix)
+ (push `(def!constant ,sym
,(+ start (* step index))
,@docs)
results)))
(1- max))))
(t nil)))
+(defun proper-list-p (x)
+ (unless (consp x)
+ (return-from proper-list-p (null x)))
+ (let ((rabbit (cdr x))
+ (turtle x))
+ (flet ((pop-rabbit ()
+ (when (eql rabbit turtle) ; circular
+ (return-from proper-list-p nil))
+ (when (atom rabbit)
+ (return-from proper-list-p (null rabbit)))
+ (pop rabbit)))
+ (loop (pop-rabbit)
+ (pop-rabbit)
+ (pop turtle)))))
+
;;; Helpers for defining error-signalling NOP's for "not supported
;;; here" operations.
(defmacro define-unsupported-fun (name &optional