0.9.9.24:
[sbcl.git] / contrib / sb-simple-streams / fndb.lisp
1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: COMMON-LISP -*-
2
3 ;;; This code is in the public domain.
4
5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
6 ;;; who placed the code in the public domain.  Sbcl port by Rudi
7 ;;; Schlatte.
8
9 (in-package "COMMON-LISP")
10
11 ;; .../compiler/knownfun.lisp
12
13
14 #||
15
16 Paul Foley (private conversation, 2003-05-17):
17
18 BTW, the RESULT-TYPE-OPEN-CLASS function in fndb.lisp is buggy.
19 Here's a (smarter) replacement:
20
21 ;; .../compiler/knownfun.lisp
22 (defun result-type-open-class (call)
23   (declare (type sb-c::combination call))
24   (let* ((not-set '#:not-set)
25          (not-constant '#:not-constant)
26          (direction not-set)
27          (if-exists not-set)
28          (if-does-not-exist not-set)
29          (class not-set))
30     ;; find (the first occurence of) each interesting keyword argument
31     (do ((args (cdr (combination-args call)) (cddr args)))
32         ((null args))
33       (macrolet ((maybe-set (var)
34                    `(when (and (eq ,var not-set) (cadr args))
35                       (if (constant-continuation-p (cadr args))
36                         (setq ,var (continuation-value (cadr args)))
37                         (setq ,var not-constant)))))
38         (case (continuation-value (car args))
39           (:direction (maybe-set direction))
40           (:if-exists (maybe-set if-exists))
41           (:if-does-not-exist (maybe-set if-does-not-exist))
42           (:class (maybe-set class)))))
43     ;; and set default values for any that weren't set above
44     (when (eq direction not-set) (setq direction :input))
45     (when (eq if-exists not-constant) (setq if-exists nil))
46     (when (eq if-does-not-exist not-constant) (set if-does-not-exist nil))
47     (when (or (eq class not-set) (eq class not-constant)) (setq class 'stream))
48     ;; now, NIL is a possible result only in the following cases:
49     ;;   direction is :probe or not-constant and :if-does-not-exist is not
50     ;;     :error
51     ;;   direction is :output or :io or not-constant and :if-exists is nil
52     ;;   :if-does-not-exist is nil
53     (if (or (and (or (eq direction :probe) (eq direction not-constant))
54                  (not (eq if-does-not-exist :error)))
55             (and (or (eq direction :output) (eq direction :io)
56                      (eq direction not-constant))
57                  (eq if-exists nil))
58             (eq if-does-not-exist nil))
59       (specifier-type `(or null ,class))
60       (specifier-type class))))
61
62 TODO (rudi 2003-05-19): make the above work, make (defknown open) use it.
63
64 ||#
65
66
67 (handler-bind ((error #'continue))
68   (sb-c:defknown open (t &rest t
69                          &key (:direction (member :input :output :io :probe))
70                          (:element-type sb-kernel:type-specifier)
71                          (:if-exists (member :error :new-version :rename
72                                              :rename-and-delete :overwrite
73                                              :append :supersede nil))
74                          (:if-does-not-exist (member :error :create nil))
75                          (:external-format keyword)
76                          (:class (or symbol class))
77                          (:mapped (member t nil))
78                          (:input-handle (or null fixnum stream))
79                          (:output-handle (or null fixnum stream))
80                          &allow-other-keys)
81     (or stream null)
82     ()
83     ;; :derive-type #'result-type-open-class
84     )
85
86   (sb-c:defknown listen (&optional sb-kernel:stream-designator
87                                    (or null (integer 1 10) (member character)))
88     boolean (sb-c::unsafely-flushable sb-c::explicit-check))
89
90   (sb-c:defknown read-sequence (sequence stream &key (:start sb-int:index)
91                                          (:end sb-kernel:sequence-end)
92                                          (:partial-fill boolean))
93     (sb-int:index) ())
94
95   (sb-c:defknown clear-input (&optional stream boolean) null
96                  (sb-c::explicit-check)))