Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4424/src/code
Modified Files:
early-extensions.lisp fd-stream.lisp function-names.lisp
stream.lisp target-defstruct.lisp target-package.lisp
Log Message:
0.9.0.38:
Fix a few ansi-test bugs:
* The type-errors signalled for invalid function names now have
a correct (if ugly) expected type.
* Functions taking type names as arguments correctly signal
type-errors (instead of package-lock errors, arg-count-errors,
etc) for some pathological non-function names (e.g (SETF),
(SETF . BAR)).
* (SETF (DOCUMENTATION ... 'STRUCTURE)) no longer signals an error
for structures defined with a :TYPE.
* Documentation strings specified in the DEFSTRUCT form for
typed structures are no longer immediately discarded (not
strictly a bug, just a quality of implementation issue...)
* FILE-STRING-LENGTH and STREAM-EXTERNAL-FORMAT now work on
non-fd-streams too.
* FILE-LENGTH now also works on broadcast streams. The spec
has slightly conflicting opinions on this issue; FILE-LENGTH
description says that stream must be associated with stream
or an error is signalled. BROADCAST-STREAM description
explicitly describes how FILE-LENGTH must be implemented.
Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -d -r1.73 -r1.74
--- early-extensions.lisp 2 May 2005 14:54:35 -0000 1.73
+++ early-extensions.lisp 19 May 2005 02:50:39 -0000 1.74
@@ -650,7 +650,7 @@
(unless (legal-fun-name-p name)
(error 'simple-type-error
:datum name
- :expected-type '(or symbol list)
+ :expected-type '(or symbol (cons (member setf) (cons symbol null)))
:format-control "invalid function name: ~S"
:format-arguments (list name))))
Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -d -r1.71 -r1.72
--- fd-stream.lisp 15 May 2005 20:09:57 -0000 1.71
+++ fd-stream.lisp 19 May 2005 02:50:40 -0000 1.72
@@ -1599,6 +1599,8 @@
(sb!sys:serve-all-events)))
(:element-type
(fd-stream-element-type fd-stream))
+ (:external-format
+ (fd-stream-external-format fd-stream))
(:interactive-p
(= 1 (the (member 0 1)
(sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
@@ -1627,6 +1629,12 @@
(if (zerop mode)
nil
(truncate size (fd-stream-element-size fd-stream)))))
+ ;; FIXME: I doubt this is correct in the presence of Unicode,
+ ;; since fd-stream FILE-POSITION is measured in bytes.
+ (:file-string-length
+ (etypecase arg1
+ (character 1)
+ (string (length arg1))))
(:file-position
(fd-stream-file-position fd-stream arg1))))
@@ -2040,29 +2048,3 @@
t)
(t
(fd-stream-pathname stream)))))
-
-;;;; international character support (which is trivial for our simple
-;;;; character sets)
-
-;;;; (Those who do Lisp only in English might not remember that ANSI
-;;;; requires these functions to be exported from package
-;;;; COMMON-LISP.)
-
-(defun file-string-length (stream object)
- (declare (type (or string character) object) (type fd-stream stream))
- #!+sb-doc
- "Return the delta in STREAM's FILE-POSITION that would be caused by writing
- OBJECT to STREAM. Non-trivial only in implementations that support
- international character sets."
- (declare (ignore stream))
- (etypecase object
- (character 1)
- (string (length object))))
-
-(defun stream-external-format (stream)
- (declare (type fd-stream stream))
- #!+sb-doc
- "Return the actual external format for fd-streams, otherwise :DEFAULT."
- (if (typep stream 'fd-stream)
- (fd-stream-external-format stream)
- :default))
Index: function-names.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/function-names.lisp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- function-names.lisp 25 May 2003 22:34:23 -0000 1.1
+++ function-names.lisp 19 May 2005 02:50:40 -0000 1.2
@@ -44,7 +44,8 @@
(otherwise nil)))
(define-function-name-syntax setf (name)
- (when (cdr name)
+ (when (and (cdr name)
+ (consp (cdr name)))
(destructuring-bind (fun &rest rest) (cdr name)
(when (null rest)
(typecase fun
Index: stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/stream.lisp,v
retrieving revision 1.77
retrieving revision 1.78
diff -u -d -r1.77 -r1.78
--- stream.lisp 16 May 2005 19:40:08 -0000 1.77
+++ stream.lisp 19 May 2005 02:50:40 -0000 1.78
@@ -115,6 +115,9 @@
(defun stream-element-type (stream)
(ansi-stream-element-type stream))
+(defun stream-external-format (stream)
+ (funcall (ansi-stream-misc stream) stream :external-format))
+
(defun interactive-stream-p (stream)
(declare (type stream stream))
(funcall (ansi-stream-misc stream) stream :interactive-p))
@@ -201,8 +204,18 @@
;; cause cross-compiler hangup.
;;
;; (declare (type (or file-stream synonym-stream) stream))
- (stream-must-be-associated-with-file stream)
+ ;;
+ ;; The description for FILE-LENGTH says that an error must be raised
+ ;; for streams not associated with files (which broadcast streams
+ ;; aren't according to the glossary). However, the behaviour of
+ ;; FILE-LENGTH for broadcast streams is explicitly described in the
+ ;; BROADCAST-STREAM entry.
+ (unless (typep stream 'broadcast-stream)
+ (stream-must-be-associated-with-file stream))
(funcall (ansi-stream-misc stream) stream :file-length))
+
+(defun file-string-length (stream object)
+ (funcall (ansi-stream-misc stream) stream :file-string-length object))
;;;; input functions
@@ -618,6 +631,8 @@
(finish-output stream))
(:element-type
(stream-element-type stream))
+ (:stream-external-format
+ (stream-external-format stream))
(:interactive-p
(interactive-stream-p stream))
(:line-length
@@ -626,6 +641,8 @@
(charpos stream))
(:file-length
(file-length stream))
+ (:file-string-length
+ (file-string-length stream arg1))
(:file-position
(file-position stream arg1))))
@@ -693,6 +710,15 @@
((null streams) res)
(when (null (cdr streams))
(setq res (stream-element-type (car streams)))))))
+ (:external-format
+ (let ((res :default))
+ (dolist (stream streams res)
+ (setq res (stream-external-format stream)))))
+ (:file-length
+ (let ((last (last streams)))
+ (if last
+ (file-length (car last))
+ 0)))
(:file-position
(if arg1
(let ((res (or (eql arg1 :start) (eql arg1 0))))
@@ -701,6 +727,10 @@
(let ((res 0))
(dolist (stream streams res)
(setq res (file-position stream))))))
+ (:file-string-length
+ (let ((res 1))
+ (dolist (stream streams res)
+ (setq res (file-string-length stream arg1)))))
(:close
(set-closed-flame stream))
(t
Index: target-defstruct.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-defstruct.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- target-defstruct.lisp 6 Jan 2005 12:47:59 -0000 1.30
+++ target-defstruct.lisp 19 May 2005 02:50:40 -0000 1.31
@@ -237,7 +237,7 @@
#'listp))))
(when (dd-doc dd)
- (setf (fdocumentation (dd-name dd) 'type)
+ (setf (fdocumentation (dd-name dd) 'structure)
(dd-doc dd)))
;; the BOUNDP test here is to get past cold-init.
Index: target-package.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-package.lisp,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- target-package.lisp 29 Apr 2005 14:37:37 -0000 1.33
+++ target-package.lisp 19 May 2005 02:50:40 -0000 1.34
@@ -237,9 +237,11 @@
#!+sb-package-locks
(let* ((symbol (etypecase name
(symbol name)
- (list (if (eq 'setf (first name))
+ (list (if (and (consp (cdr name))
+ (eq 'setf (first name)))
(second name)
- ;; Skip (class-predicate foo), etc.
+ ;; Skip lists of length 1, single conses and
+ ;; (class-predicate foo), etc.
;; FIXME: MOP and package-lock
;; interaction needs to be thought about.
(return-from
|