0.8.0.24:

[sbcl.git] / src / code / early-extensions.lisp

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index fe0f319..4888ae5 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -65,6 +65,20 @@
                          (* max-offset sb!vm:n-word-bytes))
                       scale)))
 
+;;; Similar to FUNCTION, but the result type is "exactly" specified:
+;;; if it is an object type, then the function returns exactly one
+;;; value, if it is a short form of VALUES, then this short form
+;;; specifies the exact number of values.
+(def!type sfunction (args &optional result)
+  (let ((result (cond ((eq result '*) '*)
+                      ((or (atom result)
+                           (not (eq (car result) 'values)))
+                       `(values ,result &optional))
+                      ((intersection (cdr result) lambda-list-keywords)
+                       result)
+                      (t `(values ,@(cdr result) &optional)))))
+    `(function ,args ,result)))
+
 ;;; the default value used for initializing character data. The ANSI
 ;;; spec says this is arbitrary, so we use the value that falls
 ;;; through when we just let the low-level consing code initialize
@@ -123,6 +137,11 @@
       (and (consp x)
           (list-of-length-at-least-p (cdr x) (1- n)))))
 
+(declaim (inline singleton-p))
+(defun singleton-p (list)
+  (and (consp list)
+       (null (rest list))))
+
 ;;; Is X is a positive prime integer? 
 (defun positive-primep (x)
   ;; This happens to be called only from one place in sbcl-0.7.0, and
@@ -161,7 +180,7 @@
 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
 ;;; is the pointer to the current tail of the list, or NIL if the list
 ;;; is empty.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun collect-normal-expander (n-value fun forms)
     `(progn
        ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
@@ -300,10 +319,19 @@
 (declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
 (defun nth-but-with-sane-arg-order (list index)
   (nth index list))
+
+(defun adjust-list (list length initial-element)
+  (let ((old-length (length list)))
+    (cond ((< old-length length)
+           (append list (make-list (- length old-length)
+                                   :initial-element initial-element)))
+          ((> old-length length)
+           (subseq list 0 length))
+          (t list))))
 \f
 ;;;; miscellaneous iteration extensions
 
-;;; "the ultimate iteration macro" 
+;;; "the ultimate iteration macro"
 ;;;
 ;;; note for Schemers: This seems to be identical to Scheme's "named LET".
 (defmacro named-let (name binds &body body)
@@ -601,26 +629,7 @@
 
 ;;; Is NAME a legal function name?
 (defun legal-fun-name-p (name)
-  (or (symbolp name)
-      (and (consp name)
-          ;; (SETF FOO)
-          ;; (CLASS-PREDICATE FOO)
-           (or (and (or (eq (car name) 'setf)
-                       (eq (car name) 'sb!pcl::class-predicate))
-                   (consp (cdr name))
-                   (symbolp (cadr name))
-                   (null (cddr name)))
-              ;; (SLOT-ACCESSOR <CLASSNAME-OR-:GLOBAL>
-              ;;  <SLOT-NAME> [READER|WRITER|BOUNDP])
-              (and (eq (car name) 'sb!pcl::slot-accessor)
-                   (consp (cdr name))
-                   (symbolp (cadr name))
-                   (consp (cddr name))
-                   (symbolp (caddr name))
-                   (consp (cdddr name))
-                   (member
-                    (cadddr name)
-                    '(sb!pcl::reader sb!pcl::writer sb!pcl::boundp)))))))
+  (values (valid-function-name-p name)))
 
 ;;; Signal an error unless NAME is a legal function name.
 (defun legal-fun-name-or-type-error (name)
@@ -643,11 +652,12 @@
 (defun fun-name-block-name (fun-name)
   (cond ((symbolp fun-name)
         fun-name)
-       ((and (consp fun-name)
-             (legal-fun-name-p fun-name))
-        (case (car fun-name)
-          ((setf sb!pcl::class-predicate) (second fun-name))
-          ((sb!pcl::slot-accessor) (third fun-name))))
+       ((consp fun-name)
+        (multiple-value-bind (legalp block-name)
+            (valid-function-name-p fun-name)
+          (if legalp
+              block-name
+              (error "not legal as a function name: ~S" fun-name))))
        (t
         (error "not legal as a function name: ~S" fun-name))))
 
@@ -809,12 +819,6 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
         :format-string "~@<~S ~_is not a ~_~S~:>"
         :format-arguments (list value type)))
 \f
-;;; 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)))
-
 ;;; Return a function like FUN, but expecting its (two) arguments in
 ;;; the opposite order that FUN does.
 (declaim (inline swapped-args-fun))
@@ -916,6 +920,15 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
 \f
 ;;;; utilities for two-VALUES predicates
 
+(defmacro not/type (x)
+  (let ((val (gensym "VAL"))
+        (win (gensym "WIN")))
+    `(multiple-value-bind (,val ,win)
+         ,x
+       (if ,win
+           (values (not ,val) t)
+           (values nil nil)))))
+
 (defmacro and/type (x y)
   `(multiple-value-bind (val1 win1) ,x
      (if (and (not val1) win1)