X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Ffndb.lisp;h=237cb930f6c3ea787734402d70298eb48c771dab;hb=7572e0506af331534e6f97b027d56e8bea09410c;hp=20b3d1c84ba90db06a58d8d450acc2a18bf1e93e;hpb=ac85367426b222612311c5cf7b061ff89c64d825;p=sbcl.git

diff --git a/contrib/sb-simple-streams/fndb.lisp b/contrib/sb-simple-streams/fndb.lisp
index 20b3d1c..237cb93 100644
--- a/contrib/sb-simple-streams/fndb.lisp
+++ b/contrib/sb-simple-streams/fndb.lisp
@@ -10,28 +10,61 @@
 
 ;; .../compiler/knownfun.lisp
 
-;; TODO: I suppose sbcl internals have sufficiently diverged from
-;; cmucl that this does not work after my primitive translation
-;; attempt.  This is used in the cmucl version to compute (via
-;; :derive-type arg to defknown) the return type of open.  For the
-;; time being, the new defknown form for open does not specify its
-;; return type.
-#+nil
+
+#||
+
+Paul Foley (private conversation, 2003-05-17):
+
+BTW, the RESULT-TYPE-OPEN-CLASS function in fndb.lisp is buggy.
+Here's a (smarter) replacement:
+
+;; .../compiler/knownfun.lisp
 (defun result-type-open-class (call)
   (declare (type sb-c::combination call))
-  (do ((args (sb-c::combination-args call) (cdr args)))
-      ((null args))
-    (let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (car args)))))
-      (when (and (typep leaf 'sb-kernel:constant)
-		 (eq (sb-c::constant-value leaf) :class)
-		 (cdr args))
-	(let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (cadr args)))))
-	  (return (if (typep leaf 'sb-kernel:constant)
-		      (find-class (sb-c::constant-value leaf) nil)
-		      nil)))))))
-
-(handler-bind ((error #'(lambda (condition) (declare (ignore condition))
-                                (continue))))
+  (let* ((not-set '#:not-set)
+         (not-constant '#:not-constant)
+         (direction not-set)
+         (if-exists not-set)
+         (if-does-not-exist not-set)
+         (class not-set))
+    ;; find (the first occurence of) each interesting keyword argument
+    (do ((args (cdr (combination-args call)) (cddr args)))
+        ((null args))
+      (macrolet ((maybe-set (var)
+                   `(when (and (eq ,var not-set) (cadr args))
+                      (if (constant-continuation-p (cadr args))
+                        (setq ,var (continuation-value (cadr args)))
+                        (setq ,var not-constant)))))
+        (case (continuation-value (car args))
+          (:direction (maybe-set direction))
+          (:if-exists (maybe-set if-exists))
+          (:if-does-not-exist (maybe-set if-does-not-exist))
+          (:class (maybe-set class)))))
+    ;; and set default values for any that weren't set above
+    (when (eq direction not-set) (setq direction :input))
+    (when (eq if-exists not-constant) (setq if-exists nil))
+    (when (eq if-does-not-exist not-constant) (set if-does-not-exist nil))
+    (when (or (eq class not-set) (eq class not-constant)) (setq class 'stream))
+    ;; now, NIL is a possible result only in the following cases:
+    ;;   direction is :probe or not-constant and :if-does-not-exist is not
+    ;;     :error
+    ;;   direction is :output or :io or not-constant and :if-exists is nil
+    ;;   :if-does-not-exist is nil
+    (if (or (and (or (eq direction :probe) (eq direction not-constant))
+                 (not (eq if-does-not-exist :error)))
+            (and (or (eq direction :output) (eq direction :io)
+                     (eq direction not-constant))
+                 (eq if-exists nil))
+            (eq if-does-not-exist nil))
+      (specifier-type `(or null ,class))
+      (specifier-type class))))
+
+TODO (rudi 2003-05-19): make the above work, make (defknown open) use it.
+
+||#
+
+
+(handler-bind ((error #'continue))
   (sb-c:defknown open (t &rest t
                          &key (:direction (member :input :output :io :probe))
                          (:element-type sb-kernel:type-specifier)
@@ -39,7 +72,7 @@
                                              :rename-and-delete :overwrite
                                              :append :supersede nil))
                          (:if-does-not-exist (member :error :create nil))
-                         (:external-format (member :default))
+                         (:external-format keyword)
                          (:class (or symbol class))
                          (:mapped (member t nil))
                          (:input-handle (or null fixnum stream))
@@ -50,8 +83,8 @@
     ;; :derive-type #'result-type-open-class
     )
 
-  (sb-c:defknown listen (&optional sb-kernel:streamlike
-                                   (or null (integer 1 10) (member 'character)))
+  (sb-c:defknown listen (&optional sb-kernel:stream-designator
+                                   (or null (integer 1 10) (member character)))
     boolean (sb-c::unsafely-flushable sb-c::explicit-check))
 
   (sb-c:defknown read-sequence (sequence stream &key (:start sb-int:index)