X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=26eb070c4459efb8527665743c5fec039e963d53;hb=86210c4e406c1b2ff10cc3bac0e71435867db48b;hp=de6421e1bce986bbbceb9ac1698c82cfb0d6f378;hpb=667ec9d494530079bef28e8589dd0d3274b935ec;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index de6421e..26eb070 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")) @@ -79,7 +67,9 @@ ;;; (or just find a nicer way of expressing characters portably?) -- ;;; WHN 19990713 (defconstant bell-char-code 7) +(defconstant backspace-char-code 8) (defconstant tab-char-code 9) +(defconstant line-feed-char-code 10) (defconstant form-feed-char-code 12) (defconstant return-char-code 13) (defconstant escape-char-code 27) @@ -110,8 +100,8 @@ (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)) @@ -146,6 +136,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 ;;;; @@ -193,7 +190,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) @@ -201,7 +198,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)) @@ -289,6 +286,15 @@ (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)) ;;;; miscellaneous iteration extensions @@ -371,7 +377,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)) @@ -387,7 +393,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) @@ -446,8 +452,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))))) @@ -463,8 +469,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))) @@ -555,7 +561,7 @@ ;;;; various operations on names ;;; Is NAME a legal function name? -(defun legal-function-name-p (name) +(defun legal-fun-name-p (name) (or (symbolp name) (and (consp name) (eq (car name) 'setf) @@ -565,16 +571,16 @@ ;;; 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)) +(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) +(defun fun-name-block-name (fun-name) + (cond ((symbolp fun-name) + fun-name) + ((and (consp fun-name) + (= (length fun-name) 2) + (eq (first fun-name) 'setf)) + (second 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) @@ -583,29 +589,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) ..))) @@ -618,7 +635,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 ;;;; @@ -662,10 +684,10 @@ ;;; 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") + (/show0 "entering MISSING-ARG") (error "A required &KEY or &OPTIONAL argument was not supplied.")) ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight @@ -679,16 +701,40 @@ ;;; 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~:>" @@ -927,3 +973,8 @@ (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))