1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: COMMON-LISP -*-
3 ;;; This code is in the public domain.
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
9 (in-package "COMMON-LISP")
11 ;; .../compiler/knownfun.lisp
16 Paul Foley
(private conversation
, 2003-
05-
17):
18 BTW
, the RESULT-TYPE-OPEN-CLASS function in fndb.lisp is buggy.
19 Here
's a
(smarter) replacement
:
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
)
28 (if-does-not-exist not-set
)
30 ;; find (the first occurence of) each interesting keyword argument
31 (do ((args (cdr (combination-args call
)) (cddr 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
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
))
58 (eq if-does-not-exist nil
))
59 (specifier-type `(or null
,class
))
60 (specifier-type class
))))
62 TODO
(rudi 2003-
05-
19): make the above work
, make
(defknown open
) use it.
67 ;; This adds keywords for :MAPPED, :INPUT-HANDLE :OUTPUT-HANDLE.
68 ;; But [BUG?] why is the first arg type T instead of PATHNAME-DESIGNATOR?
69 (sb-c:defknown open
(t &rest t
70 &key
(:direction
(member :input
:output
:io
:probe
))
71 (:element-type sb-kernel
:type-specifier
)
72 (:if-exists
(member :error
:new-version
:rename
73 :rename-and-delete
:overwrite
74 :append
:supersede nil
))
75 (:if-does-not-exist
(member :error
:create nil
))
76 (:external-format sb-kernel
:external-format-designator
)
77 (:class
(or symbol class
))
78 (:mapped
(member t nil
))
79 (:input-handle
(or null fixnum stream
))
80 (:output-handle
(or null fixnum stream
))
81 #+win32
(:overlapped t
))
84 ;; :derive-type #'result-type-open-class
85 :overwrite-fndb-silently t
)
87 (sb-c:defknown listen
(&optional sb-kernel
:stream-designator
88 (or null
(integer 1 10) (member character
)))
89 boolean
(sb-c::unsafely-flushable
)
90 :overwrite-fndb-silently t
)
92 (sb-c:defknown read-sequence
(sequence stream
&key
(:start sb-int
:index
)
93 (:end sb-kernel
:sequence-end
)
94 (:partial-fill boolean
))
96 :overwrite-fndb-silently t
)
98 (sb-c:defknown clear-input
(&optional stream boolean
) null
()
99 :overwrite-fndb-silently t
)