(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)
:format-control "Symbol macro name already declared constant: ~S."
:format-arguments (list name))))
name)
-
\f
;;;; DEFINE-COMPILER-MACRO
;; spec, so at least we can warn him...
(sb!c::compiler-style-warn
"defining compiler macro of (SETF ...), which will not be expanded"))
- (let ((whole (gensym "WHOLE-"))
- (environment (gensym "ENV-")))
+ (when (and (symbolp name) (special-operator-p name))
+ (error 'simple-program-error
+ :format-control "cannot define a compiler-macro for a special operator: ~S"
+ :format-arguments (list name)))
+ (with-unique-names (whole environment)
(multiple-value-bind (body local-decs doc)
(parse-defmacro lambda-list whole body name 'define-compiler-macro
:environment environment)
(let ((def `(lambda (,whole ,environment)
,@local-decs
- (block ,(fun-name-block-name name)
- ,body))))
- `(sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))
-(defun sb!c::%define-compiler-macro (name definition lambda-list doc)
- (declare (ignore lambda-list))
- (sb!c::%%define-compiler-macro name definition doc))
-(defun sb!c::%%define-compiler-macro (name definition doc)
- (setf (sb!xc:compiler-macro-function name) definition)
- ;; FIXME: Add support for (SETF FDOCUMENTATION) when object is a list
- ;; and type is COMPILER-MACRO. (Until then, we have to discard any
- ;; compiler macro documentation for (SETF FOO).)
- (unless (listp name)
- (setf (fdocumentation name 'compiler-macro) doc))
- name)
+ ,body))
+ (debug-name (sb!c::debug-namify "DEFINE-COMPILER-MACRO " name)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (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
+;;; bits of logic should be shared (notably arglist setting).
+(macrolet
+ ((def (times set-p)
+ `(eval-when (,@times)
+ (defun sb!c::%define-compiler-macro
+ (name definition lambda-list doc debug-name)
+ ,@(unless set-p
+ '((declare (ignore lambda-list debug-name))))
+ ;; FIXME: warn about incompatible lambda list with
+ ;; respect to parent function?
+ (setf (sb!xc:compiler-macro-function name) definition)
+ ;; FIXME: Add support for (SETF FDOCUMENTATION) when
+ ;; object is a list and type is COMPILER-MACRO. (Until
+ ;; then, we have to discard any compiler macro
+ ;; documentation for (SETF FOO).)
+ (unless (listp name)
+ (setf (fdocumentation name 'compiler-macro) doc))
+ ,(when set-p
+ `(case (widetag-of definition)
+ (#.sb!vm:closure-header-widetag
+ (setf (%simple-fun-arglist (%closure-fun definition))
+ lambda-list
+ (%simple-fun-name (%closure-fun definition))
+ debug-name))
+ (#.sb!vm:simple-fun-header-widetag
+ (setf (%simple-fun-arglist definition) lambda-list
+ (%simple-fun-name definition) debug-name))))
+ name))))
+ (progn
+ (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
+ #-sb-xc (def (:compile-toplevel) nil)))
\f
;;;; CASE, TYPECASE, and friends
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;;; CASE-BODY returns code for all the standard "case" macros. NAME is
;;; the macro name, and KEYFORM is the thing to case on. MULTI-P
(let ((keyform-value (gensym))
(clauses ())
(keys ()))
- (dolist (case cases)
+ (do* ((cases cases (cdr cases))
+ (case (car cases) (car cases)))
+ ((null cases) nil)
(unless (list-of-length-at-least-p case 1)
(error "~S -- bad clause in ~S" case name))
(destructuring-bind (keyoid &rest forms) case
- (cond ((memq keyoid '(t otherwise))
+ (cond ((and (memq keyoid '(t otherwise))
+ (null (cdr cases)))
(if errorp
(progn
- ;; FIXME: this message could probably do with
- ;; some loving pretty-printer format controls.
- (style-warn "Treating bare ~A in ~A as introducing a normal-clause, not an otherwise-clause" keyoid name)
+ (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))
;;;; 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))
,@(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)
#!+sb-doc
"Evaluate FORM and return the Nth value (zero based). This involves no
consing when N is a trivial constant integer."
+ ;; FIXME: The above is true, if slightly misleading. The
+ ;; MULTIPLE-VALUE-BIND idiom [ as opposed to MULTIPLE-VALUE-CALL
+ ;; (LAMBDA (&REST VALUES) (NTH N VALUES)) ] does indeed not cons at
+ ;; runtime. However, for large N (say N = 200), COMPILE on such a
+ ;; form will take longer than can be described as adequate, as the
+ ;; optional dispatch mechanism for the M-V-B gets increasingly
+ ;; hairy.
(if (integerp n)
(let ((dummy-list nil)
(keeper (gensym "KEEPER-")))
projects / sbcl.git / blobdiff