(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"))
;;; (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)
(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)
(,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)))))
(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)))
;;; 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) ..)))
"~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
(SETF FDEFINITION)~:@>"
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))))
\f
;;;; ONCE-ONLY
;;;;
;;; 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-arg))
-(defun required-arg ()
+(declaim (ftype (function () nil) missing-arg))
+(defun missing-arg ()
#!+sb-doc
- (/show0 "entering REQUIRED-ARG")
+ (/show0 "entering MISSING-ARG")
(error "A required &KEY or &OPTIONAL argument was not supplied."))
;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
;;; 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 "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
+ (bug "~@<failed AVER: ~2I~_~S~:>" 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
+ "~@<If you see this and are an SBCL ~
+developer, then it is probable that you have made a change to the ~
+system that has broken the ability for SBCL to compile, usually by ~
+removing an assumed invariant of the system, but sometimes by making ~
+an averrance that is violated (check your code!). If you are a user, ~
+please submit a bug report to the developers' mailing list, details of ~
+which can be found at <http://sbcl.sourceforge.net/>.~:@>"
+ ())))
+
(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~:>"
(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))
projects / sbcl.git / blobdiff