X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-misc.lisp;h=67e730b71e993f980d43b9ab9263f926493504e9;hb=ebc0f0ebf9efd39519ab86ba28c33abdb25443e0;hp=6c3b8ceabc817956a07bb7678b6433e7aec860d8;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 6c3b8ce..67e730b 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -31,37 +31,25 @@ (defmacro without-interrupts (&rest forms) `(progn ,@forms)) -;;; When we're running as a cross-compiler in an arbitrary host ANSI -;;; Lisp, we don't have any hooks available to manipulate the -;;; debugging name and debugging argument list of an interpreted -;;; function object (and don't care much about getting debugging name -;;; and debugging argument list right anyway). -(defun try-to-rename-interpreted-function-as-macro (f name lambda-list) - (declare (ignore f name lambda-list)) - (values)) - -;;; When we're running as a cross-compiler in an arbitrary host ANSI -;;; Lisp, we shouldn't be doing anything which is sensitive to GC. -;;; KLUDGE: I (WHN 19990131) think the proper long-term solution would -;;; be to remove any operations from cross-compiler source files -;;; (putting them in target-only source files) if they refer to these -;;; hooks. This is a short-term hack. -(defvar *before-gc-hooks* nil) -(defvar *after-gc-hooks* nil) - ;;; The GENESIS function works with fasl code which would, in the -;;; target SBCL, work on LISP-STREAMs. A true LISP-STREAM doesn't seem -;;; to be a meaningful concept in ANSI Common Lisp, but we can fake it -;;; acceptably well using a standard STREAM. -(deftype lisp-stream () 'stream) +;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended +;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a +;;; CL:STREAM. +(deftype ansi-stream () 'stream) -;;; In the target SBCL, the INSTANCE type refers to a base -;;; implementation for compound types. There's no way to express -;;; exactly that concept portably, but we can get essentially the same -;;; effect by testing for any of the standard types which would, in -;;; the target SBCL, be derived from INSTANCE: (deftype sb!kernel:instance () - '(or condition standard-object structure-object)) + '(or condition structure-object standard-object)) +(deftype sb!kernel:funcallable-instance () + (error "not clear how to represent FUNCALLABLE-INSTANCE type")) + +;;; In the target SBCL, the INSTANCE type refers to a base +;;; implementation for compound types with lowtag +;;; INSTANCE-POINTER-LOWTAG. There's no way to express exactly that +;;; concept portably, but we can get essentially the same effect by +;;; testing for any of the standard types which would, in the target +;;; SBCL, be derived from INSTANCE: +(defun %instancep (x) + (typep x '(or condition structure-object standard-object))) ;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation ;;; host Common Lisp. @@ -77,12 +65,13 @@ nil)) ;;; This seems to be the portable Common Lisp type test which -;;; corresponds to the effect of the target SBCL implementation test.. +;;; corresponds to the effect of the target SBCL implementation test... (defun sb!kernel:array-header-p (x) - (and (typep x 'simple-array) - (= 1 (array-rank x)))) + (and (typep x 'array) + (or (not (typep x 'simple-array)) + (/= (array-rank x) 1)))) -;;; Genesis needs these at cross-compile time. The target +;;; GENESIS needs these at cross-compile time. The target ;;; implementation of these is reasonably efficient by virtue of its ;;; ability to peek into the internals of the package implementation; ;;; this reimplementation is portable but slow. @@ -97,16 +86,16 @@ ;; of this function at cross-compile time don't really care if ;; the count is a little too high.) -- WHN 19990826 (multiple-value-bind (symbol status) - (find-symbol (symbol-name i) package) - (declare (ignore symbol)) - (when (member status '(:internal :inherited)) - (incf result)))) + (find-symbol (symbol-name i) package) + (declare (ignore symbol)) + (when (member status '(:internal :inherited)) + (incf result)))) result)) (defun package-external-symbol-count (package) (let ((result 0)) (declare (type fixnum result)) (do-external-symbols (i package) - (declare (ignore i)) + (declare (ignorable i)) (incf result)) result)) @@ -127,3 +116,55 @@ (defun symbol-hash (symbol) (declare (type symbol symbol)) (sxhash symbol)) + +;;; These functions are needed for constant-folding. +(defun sb!kernel:simple-array-nil-p (object) + (when (typep object 'array) + (assert (not (eq (array-element-type object) nil)))) + nil) + +(defun sb!kernel:%negate (number) + (- number)) + +(defun sb!kernel:%single-float (number) + (coerce number 'single-float)) + +(defun sb!kernel:%double-float (number) + (coerce number 'double-float)) + +(defun sb!kernel:%ldb (size posn integer) + (ldb (byte size posn) integer)) + +(defun sb!kernel:%dpb (newbyte size posn integer) + (dpb newbyte (byte size posn) integer)) + +(defun sb!kernel:%with-array-data (array start end) + (assert (typep array '(simple-array * (*)))) + (values array start end 0)) + +(defun sb!kernel:signed-byte-32-p (number) + (typep number '(signed-byte 32))) + +;;; package locking nops for the cross-compiler + +(defmacro without-package-locks (&body body) + `(progn ,@body)) + +(defmacro with-single-package-locked-error ((&optional kind thing &rest format) + &body body) + (declare (ignore kind thing format)) + `(progn ,@body)) + +(defun program-assert-symbol-home-package-unlocked (context symbol control) + (declare (ignore context control)) + symbol) + +(defun assert-package-unlocked (package &optional control &rest args) + (declare (ignore control args)) + package) + +(defun assert-symbol-home-package-unlocked (name format &key continuablep) + (declare (ignore format continuablep)) + name) + +(declaim (declaration enable-package-locks disable-package-locks))