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 ;; 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 keyword)
  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                        &allow-other-keys)
  82     (or stream null)
  83     ()
  84   ;; :derive-type #'result-type-open-class
  85   :overwrite-fndb-silently t)
  86
  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)
  91
  92 (sb-c:defknown read-sequence (sequence stream &key (:start sb-int:index)
  93                                        (:end sb-kernel:sequence-end)
  94                                        (:partial-fill boolean))
  95     (sb-int:index) ()
  96   :overwrite-fndb-silently t)
  97
  98 (sb-c:defknown clear-input (&optional stream boolean) null ()
  99   :overwrite-fndb-silently t)