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 ;; TODO: I suppose sbcl internals have sufficiently diverged from
  14 ;; cmucl that this does not work after my primitive translation
  15 ;; attempt.  This is used in the cmucl version to compute (via
  16 ;; :derive-type arg to defknown) the return type of open.  For the
  17 ;; time being, the new defknown form for open does not specify its
  18 ;; return type.
  19 #+nil
  20 (defun result-type-open-class (call)
  21   (declare (type sb-c::combination call))
  22   (do ((args (sb-c::combination-args call) (cdr args)))
  23       ((null args))
  24     (let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (car args)))))
  25       (when (and (typep leaf 'sb-kernel:constant)
  26                  (eq (sb-c::constant-value leaf) :class)
  27                  (cdr args))
  28         (let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (cadr args)))))
  29           (return (if (typep leaf 'sb-kernel:constant)
  30                       (find-class (sb-c::constant-value leaf) nil)
  31                       nil)))))))
  32
  33 (handler-bind ((error #'(lambda (condition) (declare (ignore condition))
  34                                 (continue))))
  35   (sb-c:defknown open (t &rest t
  36                          &key (:direction (member :input :output :io :probe))
  37                          (:element-type sb-kernel:type-specifier)
  38                          (:if-exists (member :error :new-version :rename
  39                                              :rename-and-delete :overwrite
  40                                              :append :supersede nil))
  41                          (:if-does-not-exist (member :error :create nil))
  42                          (:external-format (member :default))
  43                          (:class (or symbol class))
  44                          (:mapped (member t nil))
  45                          (:input-handle (or null fixnum stream))
  46                          (:output-handle (or null fixnum stream))
  47                          &allow-other-keys)
  48     (or stream null)
  49     ()
  50     ;; :derive-type #'result-type-open-class
  51     )
  52
  53   (sb-c:defknown listen (&optional sb-kernel:streamlike
  54                                    (or null (integer 1 10) (member 'character)))
  55     boolean (sb-c::unsafely-flushable sb-c::explicit-check))
  56
  57   (sb-c:defknown read-sequence (sequence stream &key (:start sb-int:index)
  58                                          (:end sb-kernel:sequence-end)
  59                                          (:partial-fill boolean))
  60     (sb-int:index) ())
  61
  62   (sb-c:defknown clear-input (&optional stream boolean) null
  63                  (sb-c::explicit-check)))