X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=cf747759d74f05b50491bcdfd74c7a62549b34c8;hb=dfae0cd85d45a30d8687d6a366b608d10350872f;hp=e272d48b1a8e5ce3178c99fcec55bd2e3f4dc75a;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index e272d48..cf74775 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -13,18 +13,6 @@ (in-package "SB!IMPL") -;;; Lots of code wants to get to the KEYWORD package or the -;;; COMMON-LISP package without a lot of fuss, so we cache them in -;;; variables. TO DO: How much does this actually buy us? It sounds -;;; sensible, but I don't know for sure that it saves space or time.. -;;; -- WHN 19990521 -;;; -;;; (The initialization forms here only matter on the cross-compilation -;;; host; In the target SBCL, these variables are set in cold init.) -(declaim (type package *cl-package* *keyword-package*)) -(defvar *cl-package* (find-package "COMMON-LISP")) -(defvar *keyword-package* (find-package "KEYWORD")) - ;;; something not EQ to anything we might legitimately READ (defparameter *eof-object* (make-symbol "EOF-OBJECT")) @@ -48,10 +36,74 @@ ;;; index leaving the loop range) (def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit))) +;;; A couple of VM-related types that are currently used only on the +;;; alpha platform. -- CSR, 2002-06-24 +(def!type unsigned-byte-with-a-bite-out (s bite) + (cond ((eq s '*) 'integer) + ((and (integerp s) (> s 0)) + (let ((bound (ash 1 s))) + `(integer 0 ,(- bound bite 1)))) + (t + (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s)))) + +;;; Motivated by the mips port. -- CSR, 2002-08-22 +(def!type signed-byte-with-a-bite-out (s bite) + (cond ((eq s '*) 'integer) + ((and (integerp s) (> s 1)) + (let ((bound (ash 1 (1- s)))) + `(integer ,(- bound) ,(- bound bite 1)))) + (t + (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) + +(def!type load/store-index (scale lowtag min-offset + &optional (max-offset min-offset)) + `(integer ,(- (truncate (+ (ash 1 16) + (* min-offset sb!vm:n-word-bytes) + (- lowtag)) + scale)) + ,(truncate (- (+ (1- (ash 1 16)) lowtag) + (* max-offset sb!vm:n-word-bytes)) + scale))) + +;;; Similar to FUNCTION, but the result type is "exactly" specified: +;;; if it is an object type, then the function returns exactly one +;;; value, if it is a short form of VALUES, then this short form +;;; specifies the exact number of values. +(def!type sfunction (args &optional result) + (let ((result (cond ((eq result '*) '*) + ((or (atom result) + (not (eq (car result) 'values))) + `(values ,result &optional)) + ((intersection (cdr result) lambda-list-keywords) + result) + (t `(values ,@(cdr result) &optional))))) + `(function ,args ,result))) + +;;; a type specifier +;;; +;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS. +;;; However, the CL:CLASS type is only defined once PCL is loaded, +;;; which is before this is evaluated. Once PCL is moved into cold +;;; init, this might be fixable. +(def!type type-specifier () '(or list symbol sb!kernel:instance)) + ;;; the default value used for initializing character data. The ANSI -;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid -;;; because it's not in the ANSI table of portable characters. -(defconstant default-init-char #\space) +;;; spec says this is arbitrary, so we use the value that falls +;;; through when we just let the low-level consing code initialize +;;; all newly-allocated memory to zero. +;;; +;;; KLUDGE: It might be nice to use something which is a +;;; STANDARD-CHAR, both to reduce user surprise a little and, probably +;;; more significantly, to help SBCL's cross-compiler (which knows how +;;; to dump STANDARD-CHARs). Unfortunately, the old CMU CL code is +;;; shot through with implicit assumptions that it's #\NULL, and code +;;; in several places (notably both DEFUN MAKE-ARRAY and DEFTRANSFORM +;;; MAKE-ARRAY) would have to be rewritten. -- WHN 2001-10-04 +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; an expression we can use to construct a DEFAULT-INIT-CHAR value + ;; at load time (so that we don't need to teach the cross-compiler + ;; how to represent and dump non-STANDARD-CHARs like #\NULL) + (defparameter *default-init-char-form* '(code-char 0))) ;;; CHAR-CODE values for ASCII characters which we care about but ;;; which aren't defined in section "2.1.3 Standard Characters" of the @@ -64,40 +116,19 @@ ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it. ;;; (or just find a nicer way of expressing characters portably?) -- ;;; WHN 19990713 -(defconstant bell-char-code 7) -(defconstant tab-char-code 9) -(defconstant form-feed-char-code 12) -(defconstant return-char-code 13) -(defconstant escape-char-code 27) -(defconstant rubout-char-code 127) +(def!constant bell-char-code 7) +(def!constant backspace-char-code 8) +(def!constant tab-char-code 9) +(def!constant line-feed-char-code 10) +(def!constant form-feed-char-code 12) +(def!constant return-char-code 13) +(def!constant escape-char-code 27) +(def!constant rubout-char-code 127) ;;;; type-ish predicates -;;; a helper function for various macros which expect clauses of a -;;; given length, etc. -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Return true if X is a proper list whose length is between MIN and - ;; MAX (inclusive). - (defun proper-list-of-length-p (x min &optional (max min)) - ;; FIXME: This implementation will hang on circular list - ;; structure. Since this is an error-checking utility, i.e. its - ;; job is to deal with screwed-up input, it'd be good style to fix - ;; it so that it can deal with circular list structure. - (cond ((minusp max) - nil) - ((null x) - (zerop min)) - ((consp x) - (and (plusp max) - (proper-list-of-length-p (cdr x) - (if (plusp (1- min)) - (1- min) - 0) - (1- max)))) - (t nil)))) - -;;; Is X a circular list? -(defun circular-list-p (x) +;;; Is X a list containing a cycle? +(defun cyclic-list-p (x) (and (listp x) (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x)))) (do ((y x (safe-cddr y)) @@ -114,6 +145,11 @@ (and (consp x) (list-of-length-at-least-p (cdr x) (1- n))))) +(declaim (inline singleton-p)) +(defun singleton-p (list) + (and (consp list) + (null (rest list)))) + ;;; Is X is a positive prime integer? (defun positive-primep (x) ;; This happens to be called only from one place in sbcl-0.7.0, and @@ -132,6 +168,13 @@ ((or (= r 0) (> d q)) (/= r 0)) (declare (fixnum inc)) (multiple-value-setq (q r) (truncate x d)))))) + +;;; Could this object contain other objects? (This is important to +;;; the implementation of things like *PRINT-CIRCLE* and the dumper.) +(defun compound-object-p (x) + (or (consp x) + (typep x 'instance) + (typep x '(array t *)))) ;;;; the COLLECT macro ;;;; @@ -145,7 +188,7 @@ ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL ;;; is the pointer to the current tail of the list, or NIL if the list ;;; is empty. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun collect-normal-expander (n-value fun forms) `(progn ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) @@ -179,7 +222,7 @@ ;;; the function is made the new value for the collection. As a ;;; totally magical special-case, FUNCTION may be COLLECT, which tells ;;; us to build a list in forward order; this is the default. If an -;;; INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd +;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd ;;; onto the end. Note that FUNCTION may be anything that can appear ;;; in the functional position, including macros and lambdas. (defmacro collect (collections &body body) @@ -187,7 +230,7 @@ (binds ())) (dolist (spec collections) (unless (proper-list-of-length-p spec 1 3) - (error "malformed collection specifier: ~S." spec)) + (error "malformed collection specifier: ~S" spec)) (let* ((name (first spec)) (default (second spec)) (kind (or (third spec) 'collect)) @@ -218,7 +261,7 @@ ;;; like (MEMBER ITEM LIST :TEST #'EQ) (defun memq (item list) #!+sb-doc - "Returns tail of LIST beginning with first element EQ to ITEM." + "Return tail of LIST beginning with first element EQ to ITEM." ;; KLUDGE: These could be and probably should be defined as ;; (MEMBER ITEM LIST :TEST #'EQ)), ;; but when I try to cross-compile that, I get an error from @@ -245,7 +288,12 @@ ;; just define ASSQ explicitly in terms of more primitive ;; operations: (dolist (pair alist) - (when (eq (car pair) item) + ;; though it may look more natural to write this as + ;; (AND PAIR (EQ (CAR PAIR) ITEM)) + ;; the temptation to do so should be resisted, as pointed out by PFD + ;; sbcl-devel 2003-08-16, as NIL elements are rare in association + ;; lists. -- CSR, 2003-08-16 + (when (and (eq (car pair) item) (not (null pair))) (return pair)))) ;;; like (DELETE .. :TEST #'EQ): @@ -275,10 +323,28 @@ (declaim (inline neq)) (defun neq (x y) (not (eq x y))) + +;;; not really an old-fashioned function, but what the calling +;;; convention should've been: like NTH, but with the same argument +;;; order as in all the other dereferencing functions, with the +;;; collection first and the index second +(declaim (inline nth-but-with-sane-arg-order)) +(declaim (ftype (function (list index) t) nth-but-with-sane-arg-order)) +(defun nth-but-with-sane-arg-order (list index) + (nth index list)) + +(defun adjust-list (list length initial-element) + (let ((old-length (length list))) + (cond ((< old-length length) + (append list (make-list (- length old-length) + :initial-element initial-element))) + ((> old-length length) + (subseq list 0 length)) + (t list)))) ;;;; miscellaneous iteration extensions -;;; "the ultimate iteration macro" +;;; "the ultimate iteration macro" ;;; ;;; note for Schemers: This seems to be identical to Scheme's "named LET". (defmacro named-let (name binds &body body) @@ -304,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) @@ -357,7 +423,7 @@ ;;; The code for initializing the cache is wrapped in a form with ;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS ;;; in type system definitions so that caches will be created -;;; before top-level forms run.) +;;; before top level forms run.) (defmacro define-hash-cache (name args &key hash-function hash-bits default (init-wrapper 'progn) (values 1)) @@ -373,7 +439,7 @@ (n-cache (gensym))) (unless (= (length default-values) values) - (error "The number of default values ~S differs from :VALUES ~D." + (error "The number of default values ~S differs from :VALUES ~W." default values)) (collect ((inlines) @@ -432,8 +498,8 @@ (,n-cache ,var-name)) (declare (type fixnum ,n-index)) ,@(sets) - ,@(mapcar #'(lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) + ,@(mapcar (lambda (i val) + `(setf (svref ,n-cache ,i) ,val)) (values-indices) (values-names)) (values))))) @@ -449,8 +515,8 @@ (dotimes (i nargs) (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil))) (arg-sets)) - ,@(mapcar #'(lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) + ,@(mapcar (lambda (i val) + `(setf (svref ,n-cache ,i) ,val)) (values-indices) default-values)) (values))) @@ -512,6 +578,40 @@ ,@(values-names)) (values ,@(values-names))) (values ,@(values-names)))))))))))) + +(defmacro define-cached-synonym + (name &optional (original (symbolicate "%" name))) + (let ((cached-name (symbolicate "%%" name "-cached"))) + `(progn + (defun-cached (,cached-name :hash-bits 8 + :hash-function (lambda (x) + (logand (sxhash x) #xff))) + ((args equal)) + (apply #',original args)) + (defun ,name (&rest args) + (,cached-name args))))) + +;;; FIXME: maybe not the best place +;;; +;;; FIXME: think of a better name -- not only does this not have the +;;; CAR recursion of EQUAL, it also doesn't have the special treatment +;;; of pathnames, bit-vectors and strings. +;;; +;;; KLUDGE: This means that we will no longer cache specifiers of the +;;; form '(INTEGER (0) 4). This is probably not a disaster. +;;; +;;; A helper function for the type system, which is the main user of +;;; these caches: we must be more conservative than EQUAL for some of +;;; our equality tests, because MEMBER and friends refer to EQLity. +;;; So: +(defun equal-but-no-car-recursion (x y) + (cond + ((eql x y) t) + ((consp x) + (and (consp y) + (eql (car x) (car y)) + (equal-but-no-car-recursion (cdr x) (cdr y)))) + (t nil))) ;;;; package idioms @@ -541,26 +641,38 @@ ;;;; various operations on names ;;; Is NAME a legal function name? -(defun legal-function-name-p (name) - (or (symbolp name) - (and (consp name) - (eq (car name) 'setf) - (consp (cdr name)) - (symbolp (cadr name)) - (null (cddr name))))) - -;;; Given a function name, return the name for the BLOCK which -;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET). -(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name)) -(defun function-name-block-name (function-name) - (cond ((symbolp function-name) - function-name) - ((and (consp function-name) - (= (length function-name) 2) - (eq (first function-name) 'setf)) - (second function-name)) +(defun legal-fun-name-p (name) + (values (valid-function-name-p name))) + +;;; Signal an error unless NAME is a legal function name. +(defun legal-fun-name-or-type-error (name) + (unless (legal-fun-name-p name) + (error 'simple-type-error + :datum name + :expected-type '(or symbol list) + :format-control "invalid function name: ~S" + :format-arguments (list name)))) + +;;; Given a function name, return the symbol embedded in it. +;;; +;;; The ordinary use for this operator (and the motivation for the +;;; name of this operator) is to convert from a function name to the +;;; name of the BLOCK which encloses its body. +;;; +;;; Occasionally the operator is useful elsewhere, where the operator +;;; name is less mnemonic. (Maybe it should be changed?) +(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) +(defun fun-name-block-name (fun-name) + (cond ((symbolp fun-name) + fun-name) + ((consp fun-name) + (multiple-value-bind (legalp block-name) + (valid-function-name-p fun-name) + (if legalp + block-name + (error "not legal as a function name: ~S" fun-name)))) (t - (error "not legal as a function name: ~S" function-name)))) + (error "not legal as a function name: ~S" fun-name)))) (defun looks-like-name-of-special-var-p (x) (and (symbolp x) @@ -569,29 +681,40 @@ (char= #\* (aref name 0)) (char= #\* (aref name (1- (length name)))))))) -;;; ANSI guarantees that some symbols are self-evaluating. This -;;; function is to be called just before a change which would affect -;;; that. (We don't absolutely have to call this function before such -;;; changes, since such changes are given as undefined behavior. In -;;; particular, we don't if the runtime cost would be annoying. But -;;; otherwise it's nice to do so.) -(defun about-to-modify (symbol) +;;; Some symbols are defined by ANSI to be self-evaluating. Return +;;; non-NIL for such symbols (and make the non-NIL value a traditional +;;; message, for use in contexts where the user asks us to change such +;;; a symbol). +(defun symbol-self-evaluating-p (symbol) (declare (type symbol symbol)) (cond ((eq symbol t) - (error "Veritas aeterna. (can't change T)")) + "Veritas aeterna. (can't change T)") ((eq symbol nil) - (error "Nihil ex nihil. (can't change NIL)")) + "Nihil ex nihil. (can't change NIL)") ((keywordp symbol) - (error "Keyword values can't be changed.")) - ;; (Just because a value is CONSTANTP is not a good enough - ;; reason to complain here, because we want DEFCONSTANT to - ;; be able to use this function, and it's legal to DEFCONSTANT - ;; a constant as long as the new value is EQL to the old - ;; value.) - )) + "Keyword values can't be changed.") + (t + nil))) + +;;; This function is to be called just before a change which would +;;; affect the symbol value. (We don't absolutely have to call this +;;; function before such changes, since such changes are given as +;;; undefined behavior. In particular, we don't if the runtime cost +;;; would be annoying. But otherwise it's nice to do so.) +(defun about-to-modify-symbol-value (symbol) + (declare (type symbol symbol)) + (let ((reason (symbol-self-evaluating-p symbol))) + (when reason + (error reason))) + ;; (Note: Just because a value is CONSTANTP is not a good enough + ;; reason to complain here, because we want DEFCONSTANT to be able + ;; to use this function, and it's legal to DEFCONSTANT a constant as + ;; long as the new value is EQL to the old value.) + (values)) + ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary -;;; assignment. That way things like +;;; assignment instead of doing cold static linking. That way things like ;;; (FLET ((FROB (X) ..)) ;;; (DEFUN FOO (X Y) (FROB X) ..) ;;; (DEFUN BAR (Z) (AND (FROB X) ..))) @@ -604,7 +727,12 @@ "~@" name) - `(setf (fdefinition ',name) ,lambda)) + ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA + ;; expression so that the compiler can use NAME in debug names etc. + (destructuring-bind (lambda-symbol &rest lambda-rest) lambda + (assert (eql lambda-symbol 'lambda)) ; else dunno how to do conversion + `(setf (fdefinition ',name) + (named-lambda ,name ,@lambda-rest)))) ;;;; ONCE-ONLY ;;;; @@ -648,11 +776,11 @@ ;;; error indicating that a required &KEY argument was not supplied. ;;; This function is also useful for DEFSTRUCT slot defaults ;;; corresponding to required arguments. -(declaim (ftype (function () nil) required-argument)) -(defun required-argument () +(declaim (ftype (function () nil) missing-arg)) +(defun missing-arg () #!+sb-doc - (/show0 "entering REQUIRED-ARGUMENT") - (error "A required &KEY argument was not supplied.")) + (/show0 "entering MISSING-ARG") + (error "A required &KEY or &OPTIONAL argument was not supplied.")) ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight ;;; @@ -665,27 +793,45 @@ ;;; guts of complex systems anyway, I replaced it too.) (defmacro aver (expr) `(unless ,expr - (%failed-aver ,(let ((*package* (find-package :keyword))) - (format nil "~S" expr))))) + (%failed-aver ,(format nil "~A" expr)))) + (defun %failed-aver (expr-as-string) - (error "~@" expr-as-string)) + (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 + "~@.~:@>" + ()))) + (defmacro enforce-type (value type) (once-only ((value value)) `(unless (typep ,value ',type) (%failed-enforce-type ,value ',type)))) + (defun %failed-enforce-type (value type) - (error 'simple-type-error + (error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG? :value value :expected-type type - :format-string "~@<~S ~_is not a ~_~S~:>" + :format-control "~@<~S ~_is not a ~_~S~:>" :format-arguments (list value type))) -;;; Return a list of N gensyms. (This is a common suboperation in -;;; macros and other code-manipulating code.) -(declaim (ftype (function (index) list) make-gensym-list)) -(defun make-gensym-list (n) - (loop repeat n collect (gensym))) - ;;; Return a function like FUN, but expecting its (two) arguments in ;;; the opposite order that FUN does. (declaim (inline swapped-args-fun)) @@ -787,6 +933,24 @@ ;;;; utilities for two-VALUES predicates +(defmacro not/type (x) + (let ((val (gensym "VAL")) + (win (gensym "WIN"))) + `(multiple-value-bind (,val ,win) + ,x + (if ,win + (values (not ,val) t) + (values nil nil))))) + +(defmacro and/type (x y) + `(multiple-value-bind (val1 win1) ,x + (if (and (not val1) win1) + (values nil t) + (multiple-value-bind (val2 win2) ,y + (if (and val1 val2) + (values t t) + (values nil (and win2 (not val2)))))))) + ;;; sort of like ANY and EVERY, except: ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does. ;;; (And if the result is uncertain, then we return (VALUES NIL NIL), @@ -899,7 +1063,6 @@ (t (error "bad option: ~S" (first option))))))))))) `(def!method print-object ((structure ,name) ,stream) - ;; FIXME: should probably be byte-compiled (pprint-logical-block (,stream nil) (print-unreadable-object (structure ,stream @@ -914,3 +1077,92 @@ (if (typep possibly-logical-pathname 'logical-pathname) (translate-logical-pathname possibly-logical-pathname) possibly-logical-pathname)) + +(defun deprecation-warning (bad-name &optional good-name) + (warn "using deprecated ~S~@[, should use ~S instead~]" + bad-name + good-name)) + +;;; Anaphoric macros +(defmacro awhen (test &body body) + `(let ((it ,test)) + (when it ,@body))) + +(defmacro acond (&rest clauses) + (if (null clauses) + `() + (destructuring-bind ((test &body body) &rest rest) clauses + (once-only ((test test)) + `(if ,test + (let ((it ,test)) (declare (ignorable it)),@body) + (acond ,@rest)))))) + +;;; (binding* ({(name initial-value [flag])}*) body) +;;; FLAG may be NIL or :EXIT-IF-NULL +;;; +;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN. +(defmacro binding* ((&rest bindings) &body body) + (let ((bindings (reverse bindings))) + (loop with form = `(progn ,@body) + for binding in bindings + do (destructuring-bind (names initial-value &optional flag) + binding + (multiple-value-bind (names declarations) + (etypecase names + (null + (let ((name (gensym))) + (values (list name) `((declare (ignorable ,name)))))) + (symbol + (values (list names) nil)) + (list + (values names nil))) + (setq form `(multiple-value-bind ,names + ,initial-value + ,@declarations + ,(ecase flag + ((nil) form) + ((:exit-if-null) + `(when ,(first names) ,form))))))) + finally (return form)))) + +;;; Delayed evaluation +(defmacro delay (form) + `(cons nil (lambda () ,form))) + +(defun force (promise) + (cond ((not (consp promise)) promise) + ((car promise) (cdr promise)) + (t (setf (car promise) t + (cdr promise) (funcall (cdr promise)))))) + +(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)))