X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=e4fa9c580b3ffc771bff6a791e1948a78938f83b;hb=4ae1b794a5d6a90794468cf8017f5307f2c30dfe;hp=b7d82b68768748204d072e0bdb9f653d8b46cb45;hpb=56ce3857f7830670d55d2fe17246353dff2e71f7;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index b7d82b6..e4fa9c5 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,6 +36,35 @@ ;;; 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))) + ;;; the default value used for initializing character data. The ANSI ;;; spec says this is arbitrary, so we use the value that falls ;;; through when we just let the low-level consing code initialize @@ -65,7 +82,6 @@ ;; 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))) -(defconstant default-init-char #.*default-init-char-form*) ;;; CHAR-CODE values for ASCII characters which we care about but ;;; which aren't defined in section "2.1.3 Standard Characters" of the @@ -78,12 +94,14 @@ ;;; 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 @@ -403,7 +421,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) @@ -462,8 +480,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))))) @@ -479,8 +497,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))) @@ -579,6 +597,15 @@ (symbolp (cadr name)) (null (cddr 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 name for the BLOCK which ;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET). (declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) @@ -632,7 +659,7 @@ ;;; 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) ..))) @@ -645,7 +672,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 ;;;; @@ -706,16 +738,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~:>" @@ -954,3 +1010,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))