X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=341c69ba0c83c49f80fa4c69c78fdd376bc21caa;hb=8eee0d3a30bf39d9f201acff28c92059fe6c3e4e;hp=61794ec8008037c5289c5d9862845588075eb62f;hpb=960a9fbd48e695e5b970a01315aa687ab59dc3fe;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 61794ec..341c69b 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -843,9 +843,9 @@
           (unless (proper-list-of-length-p spec 2)
             (error "malformed ONCE-ONLY binding spec: ~S" spec))
           (let* ((name (first spec))
-                 (exp-temp (gensym (symbol-name name))))
+                 (exp-temp (gensym "ONCE-ONLY")))
             `(let ((,exp-temp ,(second spec))
-                   (,name (gensym "ONCE-ONLY-")))
+                   (,name (gensym ,(symbol-name name))))
                `(let ((,,name ,,exp-temp))
                   ,,(frob (rest specs) body))))))))
 
@@ -1214,6 +1214,16 @@
           (*print-length* (or (true *print-length*) 12)))
       (funcall function))))
 
+;;; Returns a list of members of LIST. Useful for dealing with circular lists.
+;;; For a dotted list returns a secondary value of T -- in which case the
+;;; primary return value does not include the dotted tail.
+(defun list-members (list)
+  (when list
+    (do ((tail (cdr list) (cdr tail))
+         (members (list (car list)) (cons (car tail) members)))
+        ((or (not (consp tail)) (eq tail list))
+         (values members (not (listp tail)))))))
+
 ;;; Default evaluator mode (interpeter / compiler)
 
 (declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*))
@@ -1225,53 +1235,19 @@ to :INTERPRET, an interpreter will be used.")
 
 ;;; Helper for making the DX closure allocation in macros expanding
 ;;; to CALL-WITH-FOO less ugly.
-;;;
-;;; This expands to something like
-;;;
-;;;  (flet ((foo (...) <body-of-foo>))
-;;;     (declare (optimize stack-allocate-dynamic-extent))
-;;;     (flet ((foo (...)
-;;;              (foo ...))
-;;;        (declare (dynamic-extent #'foo))
-;;;        <body-of-dx-flet>)))
-;;;
-;;; The outer FLETs are inlined into the inner ones, and the inner ones
-;;; are DX-allocated. The double-fletting is done to keep the bodies of
-;;; the functions in an environment with correct policy: we don't want
-;;; to force DX allocation in their bodies, which would be bad eg.
-;;; in safe code.
 (defmacro dx-flet (functions &body forms)
-  (let ((names (mapcar #'car functions)))
-    `(flet ,functions
-       #-sb-xc-host
-       (declare (optimize sb!c::stack-allocate-dynamic-extent))
-       (flet ,(mapcar
-               (lambda (f)
-                 (let ((args (cadr f))
-                       (name (car f)))
-                   (when (intersection args sb!xc:lambda-list-keywords)
-                     ;; No fundamental reason not to support them, but we
-                     ;; don't currently need them here.
-                     (error "Non-required arguments not implemented for DX-FLET."))
-                   `(,name ,args
-                      (,name ,@args))))
-               functions)
-         (declare (dynamic-extent ,@(mapcar (lambda (x) `(function ,x)) names)))
-         ,@forms))))
-
-;;; Another similar one -- but actually touches the policy of the body,
-;;; so take care with this one...
+  `(flet ,functions
+     (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
+               ,@(mapcar (lambda (func) `(function ,(car func))) functions)))
+     ,@forms))
+
+;;; Another similar one.
 (defmacro dx-let (bindings &body forms)
-  `(locally
-       (declare (optimize #-sb-xc-host sb!c::stack-allocate-dynamic-extent
-                          #-sb-xc-host sb!c::stack-allocate-value-cells))
-     (let ,bindings
-       (declare (dynamic-extent ,@(mapcar (lambda (bind)
-                                            (if (consp bind)
-                                                (car bind)
-                                                bind))
-                                          bindings)))
-       ,@forms)))
+  `(let ,bindings
+     (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
+               ,@(mapcar (lambda (bind) (if (consp bind) (car bind) bind))
+                         bindings)))
+     ,@forms))
 
 (in-package "SB!KERNEL")