X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=0b2b05af094d7db4eac37edcda136ece5a4affc6;hb=447477e72bd4fe54e678a28bdcc4a2802797d6ed;hp=c590c21d0cbc5cef4af87b66c188e03c007bc263;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index c590c21..0b2b05a 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -127,16 +127,39 @@
 
 ;;;; type-ish predicates
 
-;;; Is X a list containing a cycle?
-(defun cyclic-list-p (x)
+;;; X may contain cycles -- a conservative approximation. This
+;;; occupies a somewhat uncomfortable niche between being fast for
+;;; common cases (we don't want to allocate a hash-table), and not
+;;; falling down to exponential behaviour for large trees (so we set
+;;; an arbitrady depth limit beyond which we punt).
+(defun maybe-cyclic-p (x &optional (depth-limit 12))
   (and (listp x)
-       (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
-         (do ((y x (safe-cddr y))
-              (started-p nil t)
-              (z x (cdr z)))
-             ((not (and (consp z) (consp y))) nil)
-           (when (and started-p (eq y z))
-             (return t))))))
+       (labels ((safe-cddr (cons)
+                  (let ((cdr (cdr cons)))
+                    (when (consp cdr)
+                      (cdr cdr))))
+                (check-cycle (object seen depth)
+                  (when (and (consp object)
+                             (or (> depth depth-limit)
+                                 (member object seen)
+                                 (circularp object seen depth)))
+                    (return-from maybe-cyclic-p t)))
+                (circularp (list seen depth)
+                  ;; Almost regular circular list detection, with a twist:
+                  ;; we also check each element of the list for upward
+                  ;; references using CHECK-CYCLE.
+                  (do ((fast (cons (car list) (cdr list)) (safe-cddr fast))
+                       (slow list (cdr slow)))
+                      ((not (consp fast))
+                       ;; Not CDR-circular, need to check remaining CARs yet
+                       (do ((tail slow (and (cdr tail))))
+                           ((not (consp tail))
+                            nil)
+                         (check-cycle (car tail) (cons tail seen) (1+ depth))))
+                    (check-cycle (car slow) (cons slow seen) (1+ depth))
+                    (when (eq fast slow)
+                      (return t)))))
+         (circularp x (list x) 0))))
 
 ;;; Is X a (possibly-improper) list of at least N elements?
 (declaim (ftype (function (t index)) list-of-length-at-least-p))
@@ -173,7 +196,7 @@
 ;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
 (defun compound-object-p (x)
   (or (consp x)
-      (typep x 'instance)
+      (%instancep x)
       (typep x '(array t *))))
 
 ;;;; the COLLECT macro
@@ -1184,3 +1207,13 @@
           (*print-level* (or (true *print-level*) 6))
           (*print-length* (or (true *print-length*) 12)))
       (funcall function))))
+
+;;; Default evaluator mode (interpeter / compiler)
+
+(declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*))
+(defparameter *evaluator-mode* :compile
+  #!+sb-doc
+  "Toggle between different evaluator implementations. If set to :COMPILE,
+an implementation of EVAL that calls the compiler will be used. If set
+to :INTERPRET, an interpreter will be used.")
+