X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=61c6404ec8c5591d3389050b4e11d6834ffe30d3;hb=dbfe7e6c8b06e1b0b1ba35d9894fae13e6305602;hp=481a83dfcda537095ebdfe83b98ac981f5cc6f81;hpb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;p=sbcl.git

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 481a83d..61c6404 100644
--- 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
@@ -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))))
 
 ;;;; 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)
@@ -892,6 +920,15 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
 
 ;;;; 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)
@@ -1046,3 +1083,18 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
           `(if ,test
                (let ((it ,test)) (declare (ignorable it)),@body)
                (acond ,@rest))))))
+
+
+;;; Delayed evaluation
+(defmacro delay (form)
+  `(cons nil (lambda () ,form)))
+
+(defun force (promise)
+  (cond ((not (consp promise)) promise)
+        ((car promise) (cdr promise))
+        (t (setf (car promise) t
+                 (cdr promise) (funcall (cdr promise))))))
+
+(defun promise-ready-p (promise)
+  (or (not (consp promise))
+      (car promise)))