X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Ffndb.lisp;h=2471f0713430ebe68548ef4d5bf175d0dfa6ee12;hb=1c74f342b23aafaa8f514112c9bcca7526e07a58;hp=20b3d1c84ba90db06a58d8d450acc2a18bf1e93e;hpb=ac85367426b222612311c5cf7b061ff89c64d825;p=sbcl.git diff --git a/contrib/sb-simple-streams/fndb.lisp b/contrib/sb-simple-streams/fndb.lisp index 20b3d1c..2471f07 100644 --- a/contrib/sb-simple-streams/fndb.lisp +++ b/contrib/sb-simple-streams/fndb.lisp @@ -10,54 +10,89 @@ ;; .../compiler/knownfun.lisp -;; TODO: I suppose sbcl internals have sufficiently diverged from -;; cmucl that this does not work after my primitive translation -;; attempt. This is used in the cmucl version to compute (via -;; :derive-type arg to defknown) the return type of open. For the -;; time being, the new defknown form for open does not specify its -;; return type. -#+nil + +#|| + +Paul Foley (private conversation, 2003-05-17): + +BTW, the RESULT-TYPE-OPEN-CLASS function in fndb.lisp is buggy. +Here's a (smarter) replacement: + +;; .../compiler/knownfun.lisp (defun result-type-open-class (call) (declare (type sb-c::combination call)) - (do ((args (sb-c::combination-args call) (cdr args))) - ((null args)) - (let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (car args))))) - (when (and (typep leaf 'sb-kernel:constant) - (eq (sb-c::constant-value leaf) :class) - (cdr args)) - (let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (cadr args))))) - (return (if (typep leaf 'sb-kernel:constant) - (find-class (sb-c::constant-value leaf) nil) - nil))))))) - -(handler-bind ((error #'(lambda (condition) (declare (ignore condition)) - (continue)))) - (sb-c:defknown open (t &rest t - &key (:direction (member :input :output :io :probe)) - (:element-type sb-kernel:type-specifier) - (:if-exists (member :error :new-version :rename - :rename-and-delete :overwrite - :append :supersede nil)) - (:if-does-not-exist (member :error :create nil)) - (:external-format (member :default)) - (:class (or symbol class)) - (:mapped (member t nil)) - (:input-handle (or null fixnum stream)) - (:output-handle (or null fixnum stream)) - &allow-other-keys) + (let* ((not-set '#:not-set) + (not-constant '#:not-constant) + (direction not-set) + (if-exists not-set) + (if-does-not-exist not-set) + (class not-set)) + ;; find (the first occurence of) each interesting keyword argument + (do ((args (cdr (combination-args call)) (cddr args))) + ((null args)) + (macrolet ((maybe-set (var) + `(when (and (eq ,var not-set) (cadr args)) + (if (constant-continuation-p (cadr args)) + (setq ,var (continuation-value (cadr args))) + (setq ,var not-constant))))) + (case (continuation-value (car args)) + (:direction (maybe-set direction)) + (:if-exists (maybe-set if-exists)) + (:if-does-not-exist (maybe-set if-does-not-exist)) + (:class (maybe-set class))))) + ;; and set default values for any that weren't set above + (when (eq direction not-set) (setq direction :input)) + (when (eq if-exists not-constant) (setq if-exists nil)) + (when (eq if-does-not-exist not-constant) (set if-does-not-exist nil)) + (when (or (eq class not-set) (eq class not-constant)) (setq class 'stream)) + ;; now, NIL is a possible result only in the following cases: + ;; direction is :probe or not-constant and :if-does-not-exist is not + ;; :error + ;; direction is :output or :io or not-constant and :if-exists is nil + ;; :if-does-not-exist is nil + (if (or (and (or (eq direction :probe) (eq direction not-constant)) + (not (eq if-does-not-exist :error))) + (and (or (eq direction :output) (eq direction :io) + (eq direction not-constant)) + (eq if-exists nil)) + (eq if-does-not-exist nil)) + (specifier-type `(or null ,class)) + (specifier-type class)))) + +TODO (rudi 2003-05-19): make the above work, make (defknown open) use it. + +||# + + +(sb-c:defknown open (t &rest t + &key (:direction (member :input :output :io :probe)) + (:element-type sb-kernel:type-specifier) + (:if-exists (member :error :new-version :rename + :rename-and-delete :overwrite + :append :supersede nil)) + (:if-does-not-exist (member :error :create nil)) + (:external-format keyword) + (:class (or symbol class)) + (:mapped (member t nil)) + (:input-handle (or null fixnum stream)) + (:output-handle (or null fixnum stream)) + &allow-other-keys) (or stream null) () - ;; :derive-type #'result-type-open-class - ) + ;; :derive-type #'result-type-open-class + :overwrite-fndb-silently t) - (sb-c:defknown listen (&optional sb-kernel:streamlike - (or null (integer 1 10) (member 'character))) - boolean (sb-c::unsafely-flushable sb-c::explicit-check)) +(sb-c:defknown listen (&optional sb-kernel:stream-designator + (or null (integer 1 10) (member character))) + boolean (sb-c::unsafely-flushable sb-c::explicit-check) + :overwrite-fndb-silently t) - (sb-c:defknown read-sequence (sequence stream &key (:start sb-int:index) - (:end sb-kernel:sequence-end) - (:partial-fill boolean)) - (sb-int:index) ()) +(sb-c:defknown read-sequence (sequence stream &key (:start sb-int:index) + (:end sb-kernel:sequence-end) + (:partial-fill boolean)) + (sb-int:index) () + :overwrite-fndb-silently t) - (sb-c:defknown clear-input (&optional stream boolean) null - (sb-c::explicit-check))) +(sb-c:defknown clear-input (&optional stream boolean) null + (sb-c::explicit-check) + :overwrite-fndb-silently t)