X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-misc.lisp;h=1753e34996c685c11bca39a1d83ec6878ada3f72;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=6c3b8ceabc817956a07bb7678b6433e7aec860d8;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 6c3b8ce..1753e34 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -29,39 +29,47 @@ ;;; use address-dependent (and thus GC-dependent) hashes, and we only ;;; have a single thread of control. (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) + `(macrolet ((allow-with-interrupts (&body body) + `(progn ,@body)) + (with-local-interrupts (&body body) + `(progn ,@body))) + ,@forms)) + +(defmacro with-locked-hash-table ((table) &body body) + (declare (ignore table)) + `(progn ,@body)) + +(defmacro with-locked-system-table ((table) &body body) + (declare (ignore table)) + `(progn ,@body)) + +(defmacro defglobal (name value &rest doc) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,name + (if (boundp ',name) + (symbol-value ',name) + ,value) + ,@doc))) ;;; 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 +85,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 +106,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)) @@ -117,7 +126,8 @@ ;;; the host Lisp, this is only used at cold load time, and we don't ;;; care as much about efficiency, so it's fine to treat the host ;;; Lisp's INTERN as primitive and implement INTERN* in terms of it. -(defun intern* (nameoid length package) +(defun intern* (nameoid length package &key no-copy) + (declare (ignore no-copy)) (intern (replace (make-string length) nameoid :end2 length) package)) ;;; In the target Lisp this is implemented by reading a fixed slot in @@ -127,3 +137,74 @@ (defun symbol-hash (symbol) (declare (type symbol symbol)) (sxhash symbol)) + +(defvar sb!xc:*gensym-counter* 0) + +(defun sb!xc:gensym (&optional (thing "G")) + (declare (type string thing)) + (let ((n sb!xc:*gensym-counter*)) + (prog1 + (make-symbol (concatenate 'string thing (write-to-string n :base 10 :radix nil :pretty nil))) + (incf sb!xc:*gensym-counter*)))) + +;;; 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:%with-array-data/fp (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)) + +;;; printing structures + +(defun sb!kernel::default-structure-print (structure stream depth) + (declare (ignore depth)) + (write structure :stream stream :circle t))