X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-misc.lisp;h=1753e34996c685c11bca39a1d83ec6878ada3f72;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=7a4152edab5777a63c180613c7e73ed58fed6b23;hpb=8eb6f7d3da3960c827b704e23b5a47008274be7d;p=sbcl.git diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 7a4152e..1753e34 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -29,16 +29,27 @@ ;;; use address-dependent (and thus GC-dependent) hashes, and we only ;;; have a single thread of control. (defmacro without-interrupts (&rest forms) - `(progn ,@forms)) + `(macrolet ((allow-with-interrupts (&body body) + `(progn ,@body)) + (with-local-interrupts (&body body) + `(progn ,@body))) + ,@forms)) -;;; 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) +(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 ANSI-STREAMs (streams which aren't extended @@ -46,13 +57,19 @@ ;;; 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. @@ -68,10 +85,11 @@ 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 ;;; implementation of these is reasonably efficient by virtue of its @@ -88,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)) @@ -108,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 @@ -118,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))