(defun assert-prompt (name value)
(cond ((y-or-n-p "The old value of ~S is ~S.~
- ~%Do you want to supply a new value? "
+ ~%Do you want to supply a new value? "
name value)
(format *query-io* "~&Type a form to be evaluated:~%")
(flet ((read-it () (eval (read *query-io*))))
;;; and some things (e.g., READ-CHAR) can't afford this excessive
;;; consing, we bend backwards a little.
;;;
-;;; FIXME: In reality, this restart cruft is needed hardly anywhere in
-;;; the system. Write NEED and NEED-TYPE to replace ASSERT and
-;;; CHECK-TYPE inside the system. (CL:CHECK-TYPE must still be
-;;; defined, since it's specified by ANSI and it is sometimes nice for
-;;; whipping up little things. But as far as I can tell it's not
-;;; usually very helpful deep inside the guts of a complex system like
-;;; SBCL.)
-;;;
;;; CHECK-TYPE-ERROR isn't defined until a later file because it uses
;;; the macro RESTART-CASE, which isn't defined until a later file.
(defmacro-mundanely check-type (place type &optional type-string)
(error 'simple-type-error :datum name :expected-type 'symbol
:format-control "Symbol macro name is not a symbol: ~S."
:format-arguments (list name)))
+ (with-single-package-locked-error
+ (:symbol name "defining ~A as a symbol-macro"))
(ecase (info :variable :kind name)
((:macro :global nil)
(setf (info :variable :kind name) :macro)
(let ((def `(lambda (,whole ,environment)
,@local-decs
,body))
- (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name)))
+ (debug-name (sb!c::debug-name 'compiler-macro-function name)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c::%define-compiler-macro ',name
- #',def
- ',lambda-list
- ,doc
- ,debug-name))))))
+ (sb!c::%define-compiler-macro ',name
+ #',def
+ ',lambda-list
+ ,doc
+ ',debug-name))))))
;;; FIXME: This will look remarkably similar to those who have already
;;; seen the code for %DEFMACRO in src/code/defmacro.lisp. Various
lambda-list
(%simple-fun-name (%closure-fun definition))
debug-name))
- ((#.sb!vm:simple-fun-header-widetag
- #.sb!vm:closure-fun-header-widetag)
+ (#.sb!vm:simple-fun-header-widetag
(setf (%simple-fun-arglist definition) lambda-list
(%simple-fun-name definition) debug-name))))
name))))
;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key
;;; for a given branch; otherwise, TEST is applied to the value of
;;; KEYFORM and the entire first element, instead of each part, of the
-;;; case branch. When ERRORP, no T or OTHERWISE branch is permitted,
-;;; and an ERROR form is generated. When PROCEEDP, it is an error to
+;;; case branch. When ERRORP, no OTHERWISE-CLAUSEs are recognized,
+;;; and an ERROR form is generated where control falls off the end
+;;; of the ordinary clauses. When PROCEEDP, it is an error to
;;; omit ERRORP, and the ERROR form generated is executed within a
;;; RESTART-CASE allowing KEYFORM to be set and retested.
(defun case-body (name keyform cases multi-p test errorp proceedp needcasesp)
(unless (list-of-length-at-least-p case 1)
(error "~S -- bad clause in ~S" case name))
(destructuring-bind (keyoid &rest forms) case
- (cond ((and (memq keyoid '(t otherwise))
+ (cond (;; an OTHERWISE-CLAUSE
+ ;;
+ ;; By the way... The old code here tried gave
+ ;; STYLE-WARNINGs for normal-clauses which looked as
+ ;; though they might've been intended to be
+ ;; otherwise-clauses. As Tony Martinez reported on
+ ;; sbcl-devel 2004-11-09 there are sometimes good
+ ;; reasons to write clauses like that; and as I noticed
+ ;; when trying to understand the old code so I could
+ ;; understand his patch, trying to guess which clauses
+ ;; don't have good reasons is fundamentally kind of a
+ ;; mess. SBCL does issue style warnings rather
+ ;; enthusiastically, and I have often justified that by
+ ;; arguing that we're doing that to detect issues which
+ ;; are tedious for programmers to detect for by
+ ;; proofreading (like small typoes in long symbol
+ ;; names, or duplicate function definitions in large
+ ;; files). This doesn't seem to be an issue like that,
+ ;; and I can't think of a comparably good justification
+ ;; for giving STYLE-WARNINGs for legal code here, so
+ ;; now we just hope the programmer knows what he's
+ ;; doing. -- WHN 2004-11-20
+ (and (not errorp) ; possible only in CASE or TYPECASE,
+ ; not in [EC]CASE or [EC]TYPECASE
+ (memq keyoid '(t otherwise))
(null (cdr cases)))
- (if errorp
- (progn
- (style-warn "~@<Treating bare ~A in ~A as introducing a ~
- normal-clause, not an otherwise-clause~@:>"
- keyoid name)
- (push keyoid keys)
- (push `((,test ,keyform-value ',keyoid) nil ,@forms)
- clauses))
- (push `(t nil ,@forms) clauses)))
+ (push `(t nil ,@forms) clauses))
((and multi-p (listp keyoid))
(setf keys (append keyoid keys))
(push `((or ,@(mapcar (lambda (key)
;;;; WITH-FOO i/o-related macros
(defmacro-mundanely with-open-stream ((var stream) &body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
(let ((abortp (gensym)))
`(let ((,var ,stream)
(,abortp t))
(defmacro-mundanely with-input-from-string ((var string &key index start end)
&body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
;; The ONCE-ONLY inhibits compiler note for unreachable code when
;; END is true.
(once-only ((string string))
,(or start 0)
,end)))))
,@decls
- (unwind-protect
- (progn ,@forms)
- (close ,var)
+ (multiple-value-prog1
+ (unwind-protect
+ (progn ,@forms)
+ (close ,var))
,@(when index
`((setf ,index (string-input-stream-current ,var)))))))))
-(defmacro-mundanely with-output-to-string ((var &optional string)
- &body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+(defmacro-mundanely with-output-to-string
+ ((var &optional string &key (element-type ''character))
+ &body forms-decls)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
(if string
`(let ((,var (make-fill-pointer-output-stream ,string)))
,@decls
(unwind-protect
(progn ,@forms)
(close ,var)))
- `(let ((,var (make-string-output-stream)))
+ `(let ((,var (make-string-output-stream :element-type ,element-type)))
,@decls
(unwind-protect
(progn ,@forms)
projects / sbcl.git / blobdiff