;;; 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))
+
+(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))
-;;; 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 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
;;; 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.
(defun sb!kernel:array-header-p (x)
(and (typep x 'array)
(or (not (typep x 'simple-array))
- (/= (array-rank x) 1))))
+ (/= (array-rank x) 1))))
;;; GENESIS needs these at cross-compile time. The target
;;; implementation of these is reasonably efficient by virtue of its
;; 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))
;;; 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
(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 (typep array '(simple-array * (*))))
(values array start end 0))
-#!-(or alpha x86-64)
-(progn
- (defun sb!vm::ash-left-mod32 (integer amount)
- (ldb (byte 32 0) (ash integer amount)))
- (defun sb!vm::logxor-mod32 (x y)
- (ldb (byte 32 0) (logxor x y)))
- (defun sb!vm::lognot-mod32 (x)
- (ldb (byte 32 0) (lognot x))))
-#!+(or alpha x86-64)
-(defun sb!vm::ash-left-mod64 (integer amount)
- (ldb (byte 64 0) (ash integer amount)))
+(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)
+(defmacro with-single-package-locked-error ((&optional kind thing &rest format)
+ &body body)
(declare (ignore kind thing format))
`(progn ,@body))
-(defun compiler-assert-symbol-home-package-unlocked (symbol control)
- (declare (ignore control))
+(defun program-assert-symbol-home-package-unlocked (context symbol control)
+ (declare (ignore context control))
symbol)
(defun assert-package-unlocked (package &optional control &rest args)
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))
projects / sbcl.git / blobdiff