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 (member :default))
  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)))