X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=7ae006130b78f14ff279ffc97b28ed0f0f9bc813;hb=af178240ffbda39e9c3bf584ad8ed0adcf4b6abd;hp=81b6f7b046a5bf0285d767fee01697d73b18640e;hpb=77af6d16968262049d6dadfb5521af7a8a7c6868;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 81b6f7b..7ae0061 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -370,7 +370,7 @@ ;;; Iterate over the entries in a HASH-TABLE. (defmacro dohash ((key-var value-var table &optional result) &body body) - (multiple-value-bind (forms decls) (parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (let ((gen (gensym)) (n-more (gensym))) `(with-hash-table-iterator (,gen ,table) @@ -581,7 +581,7 @@ (defmacro define-cached-synonym (name &optional (original (symbolicate "%" name))) - (let ((cached-name (symbolicate "%%" name "-cached"))) + (let ((cached-name (symbolicate "%%" name "-CACHED"))) `(progn (defun-cached (,cached-name :hash-bits 8 :hash-function (lambda (x) @@ -641,6 +641,7 @@ ;;;; various operations on names ;;; Is NAME a legal function name? +(declaim (inline legal-fun-name-p)) (defun legal-fun-name-p (name) (values (valid-function-name-p name))) @@ -649,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)))) @@ -796,29 +797,20 @@ (%failed-aver ,(format nil "~A" expr)))) (defun %failed-aver (expr-as-string) + ;; hackish way to tell we're in a cold sbcl and output the + ;; message before signallign error, as it may be this is too + ;; early in the cold init. + (when (find-package "SB!C") + (fresh-line) + (write-line "failed AVER:") + (write-line expr-as-string) + (terpri)) (bug "~@" expr-as-string)) -;;; We need a definition of BUG here for the host compiler to be able -;;; to deal with BUGs in sbcl. This should never affect an end-user, -;;; who will pick up the definition that signals a CONDITION of -;;; condition-class BUG; however, this is not defined on the host -;;; lisp, but for the target. SBCL developers sometimes trigger BUGs -;;; in their efforts, and it is useful to get the details of the BUG -;;; rather than an undefined function error. - CSR, 2002-04-12 -#+sb-xc-host (defun bug (format-control &rest format-arguments) - (error 'simple-error - :format-control "~@< ~? ~:@_~?~:>" - :format-arguments `(,format-control - ,format-arguments - "~@.~:@>" - ()))) + (error 'bug + :format-control format-control + :format-arguments format-arguments)) (defmacro enforce-type (value type) (once-only ((value value)) @@ -826,8 +818,10 @@ which can be found at .~:@>" (%failed-enforce-type ,value ',type)))) (defun %failed-enforce-type (value type) - (error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG? - :value value + ;; maybe should be TYPE-BUG, subclass of BUG? If it is changed, + ;; check uses of it in user-facing code (e.g. WARN) + (error 'simple-type-error + :datum value :expected-type type :format-control "~@<~S ~_is not a ~_~S~:>" :format-arguments (list value type))) @@ -1097,7 +1091,7 @@ which can be found at .~:@>" (let ((it ,test)) (declare (ignorable it)),@body) (acond ,@rest)))))) -;;; (binding* ({(name initial-value [flag])}*) body) +;;; (binding* ({(names initial-value [flag])}*) body) ;;; FLAG may be NIL or :EXIT-IF-NULL ;;; ;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN. @@ -1115,7 +1109,15 @@ which can be found at .~:@>" (symbol (values (list names) nil)) (list - (values names nil))) + (collect ((new-names) (ignorable)) + (dolist (name names) + (when (eq name nil) + (setq name (gensym)) + (ignorable name)) + (new-names name)) + (values (new-names) + (when (ignorable) + `((declare (ignorable ,@(ignorable))))))))) (setq form `(multiple-value-bind ,names ,initial-value ,@declarations @@ -1138,3 +1140,45 @@ which can be found at .~:@>" (defun promise-ready-p (promise) (or (not (consp promise)) (car promise))) + +;;; toplevel helper +(defmacro with-rebound-io-syntax (&body body) + `(%with-rebound-io-syntax (lambda () ,@body))) + +(defun %with-rebound-io-syntax (function) + (declare (type function function)) + (let ((*package* *package*) + (*print-array* *print-array*) + (*print-base* *print-base*) + (*print-case* *print-case*) + (*print-circle* *print-circle*) + (*print-escape* *print-escape*) + (*print-gensym* *print-gensym*) + (*print-length* *print-length*) + (*print-level* *print-level*) + (*print-lines* *print-lines*) + (*print-miser-width* *print-miser-width*) + (*print-pretty* *print-pretty*) + (*print-radix* *print-radix*) + (*print-readably* *print-readably*) + (*print-right-margin* *print-right-margin*) + (*read-base* *read-base*) + (*read-default-float-format* *read-default-float-format*) + (*read-eval* *read-eval*) + (*read-suppress* *read-suppress*) + (*readtable* *readtable*)) + (funcall function))) + +;;; Bind a few "potentially dangerous" printer control variables to +;;; safe values, respecting current values if possible. +(defmacro with-sane-io-syntax (&body forms) + `(call-with-sane-io-syntax (lambda () ,@forms))) + +(defun call-with-sane-io-syntax (function) + (declare (type function function)) + (macrolet ((true (sym) + `(and (boundp ',sym) ,sym))) + (let ((*print-readably* nil) + (*print-level* (or (true *print-level*) 6)) + (*print-length* (or (true *print-length*) 12))) + (funcall function))))