Fix make-array transforms.
[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 (sb-c:defknown open (t &rest t
68                        &key (:direction (member :input :output :io :probe))
69                        (:element-type sb-kernel:type-specifier)
70                        (:if-exists (member :error :new-version :rename
71                                                   :rename-and-delete :overwrite
72                                                   :append :supersede nil))
73                        (:if-does-not-exist (member :error :create nil))
74                        (:external-format keyword)
75                        (:class (or symbol class))
76                        (:mapped (member t nil))
77                        (:input-handle (or null fixnum stream))
78                        (:output-handle (or null fixnum stream))
79                        &allow-other-keys)
80     (or stream null)
81     ()
82   ;; :derive-type #'result-type-open-class
83   :overwrite-fndb-silently t)
84
85 (sb-c:defknown listen (&optional sb-kernel:stream-designator
86                                  (or null (integer 1 10) (member character)))
87     boolean (sb-c::unsafely-flushable sb-c::explicit-check)
88   :overwrite-fndb-silently t)
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   :overwrite-fndb-silently t)
95
96 (sb-c:defknown clear-input (&optional stream boolean) null
97     (sb-c::explicit-check)
98   :overwrite-fndb-silently t)