problem with quotas, I don't know.)
To build the system binaries:
+ 0. If you want to be on the bleeding edge, you can update your
+ sources to the latest development snapshot (or any previous
+ development snapshot, for that matter) by using anonymous CVS
+ to SourceForge. (This is not recommended if you're just using SBCL
+ as a tool for other work, but if you're interested in working on
+ SBCL itself, it's a good idea.) Follow the "CVS Repository" link on
+ <http://sourceforge.net/projects/sbcl> for instructions.
1. Make sure that you have enough RAM+swap to build SBCL, as
per the CAUTION note above. (As of version 0.6.0, the most
memory-intensive operation in make.sh is the second call to
2. If the GNU make command is not available under the name "gmake",
then define the environment variable GNUMAKE to a name where it can
be found.
- 3. If you like, you can edit the base-features.lisp-expr file
+ 3. If you like, you can edit the base-target-features.lisp-expr file
to customize the resulting Lisp system. By enabling or disabling
features in this file, you can create a smaller system, or one
with extra code for debugging output or error-checking or other things.
changes in sbcl-0.6.8 relative to sbcl-0.6.7:
-?? The system is now under CVS at SourceForge (instead of the
+* The system is now under CVS at SourceForge (instead of the
CVS repository on my home machine).
-?? The INSTALL file has been updated with some information
- about using anonymous CVS to download the most recent version
- from SourceForge.
-?? There's now code in the tests/ subdirectory to run the system
- through the clocc/ansi-tests/ suite, and to run additional
- SBCL-specific regression tests as well. (It's not particularly
- mature right now, but it's a start.)
+* The new signal handling code has been tweaked to treat register
+ contents as (UNSIGNED-BYTE 32), as the old CMU CL code did,
+ instead of (SIGNED-BYTE 32), as the C header files have it. (Code
+ downstream, e.g. in debug-int.lisp, has implicit dependencies
+ on the unsignedness of integer representation of machine words,
+ and that caused the system to bomb out with infinite regress
+ when trying to recover from type errors involving signed values,
+ e.g. (BUTLAST '(1 2 3) -1).)
?? The system now uses code based on Colin Walters' O(N)
implementation of MAP (from the cmucl-imp@cons.org mailing
list, 2 September 2000) when it can't use a DEFTRANSFORM to
CREDITS file.)
?? The debugger now flushes standard output streams before it begins
its output ("debugger invoked" and so forth).
-?? The two problem cases reported by Peter Van Eynde on 8 Sep 2000,
- (BUTLAST '(1 2 3) -1) and (MAKE-LIST -1), now work, and test cases
- have now been added to the regression test suite to keep them
- from appearing again. (This was a repeat appearance, alas!)
- As the regression test system gets more mature, I intend to add
- most future fixed bugs to it, but at this point I'm still playing
- with it.
?? The patch for the SUBSEQ bug reported on the cmucl-imp mailing
list 12 September 2000 has been applied to SBCL.
?? Martin Atzmueller's versions of two CMU CL patches, as posted on
PROBLEM:
As long as I'm working on the batch-related command-line options,
it would be reasonable to add one more option to "do what I'd want",
- testing standard input for TTY-ness and running in no-programmer
+ testing standard input for non-TTY-ness and running in no-programmer
mode if so.
FIX:
?? Do it.
some functions, and I never realized that there's a wrapper-based
facility too until I was wading through the source code for SBCL.
Yes, I know I should have RTFM, but there is a lot of M..
+ (By the way, it would also be nice to have tracing behave
+ better with generic functions. TRACEing a generic function probably
+ shouldn't prevent DEFMETHOD from being used to redefine its
+ methods, and should perhaps trace each of its methods as well
+ as the generic function itself.)
FIX:
?? possibility 1: Add error-handling code in ntrace.lisp to
catch failure to set breakpoints and retry using
??
-------------------------------------------------------------------------------
PROBLEM:
- My system of parallel build directories doesn't seem to add value.
+ My system of parallel build directories seems to add
+ complexity without adding value.
FIX:
?? Replace it with a system where fasl output files live in the
same directories as the sources and have names a la
The hashing code is new and should be tested.
FIX:
?? Enable the existing test code.
--------------------------------------------------------------------------------
-PROBLEM:
- My ad hoc system of revision control is looking pretty clunky,
- and I've pretty much stopped doing stuff to confuse CVS (like moving
- directories around).
-FIX:
- ?? Check into CVS.
- ?? Make sure that the tags in FILE-COMMENTs expand correctly.
- ?? See about automatically propagating version information
- from CVS into the runtime.c banner message and the
- LISP-IMPLEMENTATION-VERSION string.
===============================================================================
other known issues with no particular target date:
;; If you want to be able to use the extra debugging information,
;; therefore, be sure to keep the sources around, and run with the
;; readtable configured so that the system sources can be read.
- ; :sb-show
+ ;:sb-show
;; Enable extra debugging output in the assem.lisp assembler/scheduler
;; code. (This is the feature which was called :DEBUG in the
(*print-level* 5))
(sb!int:/show "about to LOAD warm.lisp")
(load "src/cold/warm.lisp"))
- (sb-int:/show "about to SAVE-LISP-AND-DIE")
+ (sb-int:/show "done with warm.lisp, about to SAVE-LISP-AND-DIE")
;; Even if /SHOW output was wanted during build, it's probably
;; not wanted by default after build is complete. (And if it's
;; wanted, it can easily be turned back on.)
(or (compiled-debug-var-save-sc-offset debug-var)
(compiled-debug-var-sc-offset debug-var))))))
+;;; a helper function for working with possibly-invalid values:
+;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
+;;;
+;;; (Such values can arise in registers on machines with conservative
+;;; GC, and might also arise in debug variable locations when
+;;; those variables are invalid.)
+(defun make-valid-lisp-obj (val)
+ (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..")
+ #!+sb-show (%primitive print (sb!impl::hexstr val))
+ (if (or
+ ;; fixnum
+ (zerop (logand val 3))
+ ;; character
+ (and (zerop (logand val #xffff0000)) ; Top bits zero
+ (= (logand val #xff) sb!vm:base-char-type)) ; Char tag
+ ;; unbound marker
+ (= val sb!vm:unbound-marker-type)
+ ;; pointer
+ (and (logand val 1)
+ ;; Check that the pointer is valid. XXX Could do a better
+ ;; job. FIXME: e.g. by calling out to an is_valid_pointer
+ ;; routine in the C runtime support code
+ (or (< (sb!impl::read-only-space-start) val
+ (* sb!impl::*read-only-space-free-pointer*
+ sb!vm:word-bytes))
+ (< (sb!impl::static-space-start) val
+ (* sb!impl::*static-space-free-pointer*
+ sb!vm:word-bytes))
+ (< (sb!impl::current-dynamic-space-start) val
+ (sap-int (dynamic-space-free-pointer))))))
+ (make-lisp-obj val)
+ :invalid-object))
+
;;; CMU CL had
;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..)
;;; code for this case.
#!+x86
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(declare (type system-area-pointer fp))
+ (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..")
+ #!+sb-show (%primitive print (sb!impl::hexstr fp))
+ #!+sb-show (%primitive print (sb!impl::hexstr sc-offset))
+ #!+sb-show (%primitive print (sb!impl::hexstr escaped))
(macrolet ((with-escaped-value ((var) &body forms)
`(if escaped
- (let ((,var (sb!vm:context-register
- escaped (sb!c:sc-offset-offset sc-offset))))
- ,@forms)
- :invalid-value-for-unescaped-register-storage))
+ (let ((,var (sb!vm:context-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset))))
+ (/show0 "in escaped case, ,VAR value=..")
+ #!+sb-show (%primitive print (sb!impl::hexstr ,var))
+ ,@forms)
+ :invalid-value-for-unescaped-register-storage))
(escaped-float-value (format)
`(if escaped
- (sb!vm:context-float-register
- escaped (sb!c:sc-offset-offset sc-offset) ',format)
- :invalid-value-for-unescaped-register-storage))
+ (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) ',format)
+ :invalid-value-for-unescaped-register-storage))
(escaped-complex-float-value (format)
`(if escaped
- (complex
- (sb!vm:context-float-register
- escaped (sb!c:sc-offset-offset sc-offset) ',format)
- (sb!vm:context-float-register
- escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format))
- :invalid-value-for-unescaped-register-storage))
- ;; The debug variable locations are not always valid, and
- ;; on the x86 locations can contain raw values. To
- ;; prevent later problems from invalid objects, they are
- ;; filtered here.
- (make-valid-lisp-obj (val)
- `(if (or
- ;; fixnum
- (zerop (logand ,val 3))
- ;; character
- (and (zerop (logand ,val #xffff0000)) ; Top bits zero
- (= (logand ,val #xff) sb!vm:base-char-type)) ; Char tag
- ;; unbound marker
- (= ,val sb!vm:unbound-marker-type)
- ;; pointer
- (and (logand ,val 1)
- ;; Check that the pointer is valid. XXX Could do a
- ;; better job.
- (or (< (sb!impl::read-only-space-start) ,val
- (* sb!impl::*read-only-space-free-pointer*
- sb!vm:word-bytes))
- (< (sb!impl::static-space-start) ,val
- (* sb!impl::*static-space-free-pointer*
- sb!vm:word-bytes))
- (< (sb!impl::current-dynamic-space-start) ,val
- (sap-int (dynamic-space-free-pointer))))))
- (make-lisp-obj ,val)
- :invalid-object)))
+ (complex
+ (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) ',format)
+ (sb!vm:context-float-register
+ escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format))
+ :invalid-value-for-unescaped-register-storage)))
(ecase (sb!c:sc-offset-scn sc-offset)
((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
+ (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER")
(without-gcing
(with-escaped-value (val)
+ (/show0 "VAL=..")
+ #!+sb-show (%primitive print (sb!impl::hexstr val))
(make-valid-lisp-obj val))))
(#.sb!vm:base-char-reg-sc-number
+ (/show0 "case of BASE-CHAR-REG-SC-NUMBER")
(with-escaped-value (val)
(code-char val)))
(#.sb!vm:sap-reg-sc-number
+ (/show0 "case of SAP-REG-SC-NUMBER")
(with-escaped-value (val)
(int-sap val)))
(#.sb!vm:signed-reg-sc-number
+ (/show0 "case of SIGNED-REG-SC-NUMBER")
(with-escaped-value (val)
(if (logbitp (1- sb!vm:word-bits) val)
(logior val (ash -1 sb!vm:word-bits))
val)))
(#.sb!vm:unsigned-reg-sc-number
+ (/show0 "case of UNSIGNED-REG-SC-NUMBER")
(with-escaped-value (val)
val))
(#.sb!vm:single-reg-sc-number
+ (/show0 "case of SINGLE-REG-SC-NUMBER")
(escaped-float-value single-float))
(#.sb!vm:double-reg-sc-number
+ (/show0 "case of DOUBLE-REG-SC-NUMBER")
(escaped-float-value double-float))
#!+long-float
(#.sb!vm:long-reg-sc-number
+ (/show0 "case of LONG-REG-SC-NUMBER")
(escaped-float-value long-float))
(#.sb!vm:complex-single-reg-sc-number
+ (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER")
(escaped-complex-float-value single-float))
(#.sb!vm:complex-double-reg-sc-number
+ (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER")
(escaped-complex-float-value double-float))
#!+long-float
(#.sb!vm:complex-long-reg-sc-number
+ (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER")
(escaped-complex-float-value long-float))
(#.sb!vm:single-stack-sc-number
+ (/show0 "case of SINGLE-STACK-SC-NUMBER")
(sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:word-bytes))))
(#.sb!vm:double-stack-sc-number
+ (/show0 "case of DOUBLE-STACK-SC-NUMBER")
(sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
sb!vm:word-bytes))))
#!+long-float
(#.sb!vm:long-stack-sc-number
+ (/show0 "case of LONG-STACK-SC-NUMBER")
(sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
sb!vm:word-bytes))))
(#.sb!vm:complex-single-stack-sc-number
+ (/show0 "case of COMPLEX-STACK-SC-NUMBER")
(complex
(sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:word-bytes)))
(sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
sb!vm:word-bytes)))))
(#.sb!vm:complex-double-stack-sc-number
+ (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER")
(complex
(sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
sb!vm:word-bytes)))
sb!vm:word-bytes)))))
#!+long-float
(#.sb!vm:complex-long-stack-sc-number
+ (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER")
(complex
(sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
sb!vm:word-bytes)))
(sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
sb!vm:word-bytes)))))
(#.sb!vm:control-stack-sc-number
+ (/show0 "case of CONTROL-STACK-SC-NUMBER")
(stack-ref fp (sb!c:sc-offset-offset sc-offset)))
(#.sb!vm:base-char-stack-sc-number
+ (/show0 "case of BASE-CHAR-STACK-SC-NUMBER")
(code-char
(sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:word-bytes)))))
(#.sb!vm:unsigned-stack-sc-number
+ (/show0 "case of UNSIGNED-STACK-SC-NUMBER")
(sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:word-bytes))))
(#.sb!vm:signed-stack-sc-number
+ (/show0 "case of SIGNED-STACK-SC-NUMBER")
(signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:word-bytes))))
(#.sb!vm:sap-stack-sc-number
+ (/show0 "case of SAP-STACK-SC-NUMBER")
(sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:word-bytes)))))))
;;;; 254 => read next two bytes for integer
;;;; 255 => read next four bytes for integer
-;;; Given a byte vector Vec and an index variable Index, read a variable
-;;; length integer and advance index.
+;;; Given a byte vector VEC and an index variable INDEX, read a
+;;; variable length integer and advance index.
+;;;
+;;; FIXME: This is called O(20) times. It should be reimplemented
+;;; with much of its logic in a single service function which can
+;;; be called by the macro expansion:
+;;; `(SETF ,INDEX (%READ-VAR-INTEGER ,VEC ,INDEX)).
(defmacro read-var-integer (vec index)
(once-only ((val `(aref ,vec ,index)))
`(cond ((<= ,val 253)
function))))
(%enumerate-files head pathname verify-existence function)))
-;;; REMOVEME after finding bug.
-#!+sb-show (defvar *show-directory*)
-#!+sb-show (defvar *show-name*)
-
(defun %enumerate-files (directory pathname verify-existence function)
(declare (simple-string directory))
(/show0 "entering %ENUMERATE-FILES")
(sb!unix:close-dir dir)))))
(t
(/show0 "default case")
-
- ;; Put DIRECTORY and NAME somewhere we can find them even when
- ;; things are too screwed up for the debugger.
- #!+sb-show (progn
- (setf *show-directory* directory
- *show-name* name))
-
(let ((file (concatenate 'string directory name)))
(/show0 "computed basic FILE=..")
#!+sb-show (%primitive print file)
(fp (gensym))
(context (gensym))
(sc-offsets (gensym))
- (temp (gensym))
(fn-name (symbolicate name "-HANDLER")))
`(progn
;; FIXME: Having a separate full DEFUN for each error doesn't
;; seem to add much value, and it takes a lot of space. Perhaps
- ;; we could make this a big CASE statement instead?
+ ;; we could do this dispatch with a big CASE statement instead?
(defun ,fn-name (name ,fp ,context ,sc-offsets)
;; FIXME: Perhaps put in OPTIMIZE declaration to make this
;; byte coded.
;; where his error was detected instead of telling him where
;; he ended up inside the system error-handling logic.
(declare (ignorable name ,fp ,context ,sc-offsets))
- (macrolet ((set-value (var value)
- (let ((pos (position var ',required)))
- (unless pos
- (error "~S isn't one of the required args." var))
- `(let ((,',temp ,value))
- (sb!di::sub-set-debug-var-slot
- ,',fp (nth ,pos ,',sc-offsets)
- ,',temp ,',context)
- (setf ,var ,',temp)))))
- (let (,@(let ((offset -1))
- (mapcar #'(lambda (var)
- `(,var (sb!di::sub-access-debug-var-slot
- ,fp
- (nth ,(incf offset)
- ,sc-offsets)
- ,context)))
- required))
- ,@(when rest-pos
- `((,(nth (1+ rest-pos) args)
- (mapcar #'(lambda (sc-offset)
- (sb!di::sub-access-debug-var-slot
+ (/show0 "about to do outer LETs in DEFERR macroexpanded DEFUN")
+ (let (,@(let ((offset -1))
+ (mapcar #'(lambda (var)
+ `(,var (sb!di::sub-access-debug-var-slot
,fp
- sc-offset
- ,context))
- (nthcdr ,rest-pos ,sc-offsets))))))
- ,@body)))
+ (nth ,(incf offset)
+ ,sc-offsets)
+ ,context)))
+ required))
+ ,@(when rest-pos
+ `((,(nth (1+ rest-pos) args)
+ (mapcar #'(lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ ,fp
+ sc-offset
+ ,context))
+ (nthcdr ,rest-pos ,sc-offsets))))))
+ ,@body))
(setf (svref *internal-errors* ,(error-number-or-lose name))
#',fn-name))))
:operands (list this that)))
(deferr object-not-type-error (object type)
+ (/show0 "entering body of DEFERR OBJECT-NOT-TYPE-ERROR, OBJECT,TYPE=..")
+ #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr object))
+ #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr type))
(error (if (and (typep object 'instance)
(layout-invalid (%instance-layout object)))
'layout-invalid
(defun internal-error (context continuable)
(declare (type system-area-pointer context) (ignore continuable))
+ (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
+ #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr context))
(infinite-error-protect
(let ((context (locally
- (declare (optimize (inhibit-warnings 3)))
- (sb!alien:sap-alien context (* os-context-t)))))
+ (declare (optimize (inhibit-warnings 3)))
+ (sb!alien:sap-alien context (* os-context-t)))))
(multiple-value-bind (error-number arguments)
(sb!vm:internal-error-arguments context)
(multiple-value-bind (name sb!debug:*stack-top-hint*)
((not (functionp handler))
(error 'simple-error
:function-name name
- :format-control
- "internal error ~D: ~A; args=~S"
+ :format-control "internal error ~D: ~A; args=~S"
:format-arguments
(list error-number
handler
;;;; and internal error handling) the extra runtime cost should be
;;;; negligible.
-(def-alien-routine ("os_context_pc_addr" context-pc-addr) (* int)
+(def-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
+ ;; (Note: Just as in CONTEXT-REGISTER-ADDR, we intentionally use an
+ ;; 'unsigned *' interpretation for the 32-bit word passed to us by
+ ;; the C code, even though the C code may think it's an 'int *'.)
(context (* os-context-t)))
(defun context-pc (context)
(declare (type (alien (* os-context-t)) context))
(int-sap (deref (context-pc-addr context))))
-(def-alien-routine ("os_context_register_addr" context-register-addr) (* int)
+(def-alien-routine ("os_context_register_addr" context-register-addr)
+ (* unsigned-int)
+ ;; (Note the mismatch here between the 'int *' value that the C code
+ ;; may think it's giving us and the 'unsigned *' value that we
+ ;; receive. It's intentional: the C header files may think of
+ ;; register values as signed, but the CMU CL code tends to think of
+ ;; register values as unsigned, and might get bewildered if we ask
+ ;; it to work with signed values.)
(context (* os-context-t))
(index int))
+;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
+;;; (Are they used in anything time-critical, or just the debugger?)
(defun context-register (context index)
(declare (type (alien (* os-context-t)) context))
(deref (context-register-addr context index)))
(defun %set-context-register (context index new)
- (declare (type (alien (* os-context-t)) context))
- (setf (deref (context-register-addr context index))
- new))
+(declare (type (alien (* os-context-t)) context))
+(setf (deref (context-register-addr context index))
+ new))
;;; Like CONTEXT-REGISTER, but returns the value of a float register.
;;; FORMAT is the type of float to return.
;;; so it's stubbed out. Someday, in order to make the debugger work
;;; better, it may be necessary to unstubify it.
(defun context-float-register (context index format)
- (declare (ignore context index format))
+ (declare (ignore context index))
(warn "stub CONTEXT-FLOAT-REGISTER")
- (coerce 0.0 'format))
+ (coerce 0.0 format))
(defun %set-context-float-register (context index format new-value)
- (declare (ignore context index format))
+ (declare (ignore context index))
(warn "stub %SET-CONTEXT-FLOAT-REGISTER")
- (coerce new-value 'format))
+ (coerce new-value format))
;;; Given a signal context, return the floating point modes word in
;;; the same format as returned by FLOATING-POINT-MODES.
;;; arguments from the instruction stream.
(defun internal-error-arguments (context)
(declare (type (alien (* os-context-t)) context))
+ (/show0 "entering INTERNAL-ERROR-ARGUMENTS, CONTEXT=..")
+ #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr context))
(let ((pc (context-pc context)))
(declare (type system-area-pointer pc))
;; using INT3 the pc is .. INT3 <here> code length bytes...
(let* ((length (sap-ref-8 pc 1))
- (vector (make-specializable-array
- length
- :element-type '(unsigned-byte 8))))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
(declare (type (unsigned-byte 8) length)
(type (simple-array (unsigned-byte 8) (*)) vector))
+ (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..")
+ #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr length))
+ #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr vector))
(copy-from-system-area pc (* sb!vm:byte-bits 2)
vector (* sb!vm:word-bits
sb!vm:vector-data-offset)
(* length sb!vm:byte-bits))
(let* ((index 0)
(error-number (sb!c::read-var-integer vector index)))
+ #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr error-number))
(collect ((sc-offsets))
(loop
+ (/show0 "INDEX=..")
+ #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr index))
(when (>= index length)
(return))
- (sc-offsets (sb!c::read-var-integer vector index)))
+ (let ((sc-offset (sb!c::read-var-integer vector index)))
+ (/show0 "SC-OFFSET=..")
+ #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr sc-offset))
+ (sc-offsets sc-offset)))
(values error-number (sc-offsets)))))))
\f
;;; Do whatever is necessary to make the given code component
os_context_t *context = (os_context_t*)void_context;
unsigned int trap;
- SHOW("entering sigtrap_handler(..)"); /* REMOVEME */
-
if (single_stepping && (signal==SIGTRAP))
{
/* fprintf(stderr,"* single step trap %x\n", single_stepping); */
* here, and restore it after we do our thing, but there
* seems to be no point in doing that, since we're just
* going to lose(..) anyway. */
- SHOW("in trap_Halt case of sigtrap_handler(..)"); /* REMOVEME */
fake_foreign_function_call(context);
lose("%%primitive halt called; the party is over.");
interrupt_handle_now(signal, info, context);
break;
}
- SHOW("leaving sigtrap_handler(..)"); /* REMOVEME */
}
void
+++ /dev/null
-;;;; some stuff to check that bignum operations are returning correct
-;;;; results
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!BIGNUM")
-
-(file-comment
- "$Header$")
-
-(defvar *in-bignum-wrapper* nil)
-
-(defmacro def-bignum-wrapper (name lambda-list &body body)
- (let ((var-name (sb!int:symbolicate "*OLD-" name "*"))
- (wrap-name (sb!int:symbolicate "WRAP-" name))
- (args (mapcar #'(lambda (x)
- (if (listp x) (car x) x))
- (remove-if #'(lambda (x)
- (member x lambda-list-keywords))
- lambda-list))))
- `(progn
- (defvar ,var-name (fdefinition ',name))
- (defun ,wrap-name ,lambda-list
- (if *in-bignum-wrapper*
- (funcall ,var-name ,@args)
- (let ((*in-bignum-wrapper* t))
- ,@body)))
- (setf (fdefinition ',name) #',wrap-name))))
-
-(defun big= (x y)
- (= (if (typep x 'bignum)
- (%normalize-bignum x (%bignum-length x))
- x)
- (if (typep y 'bignum)
- (%normalize-bignum y (%bignum-length y))
- y)))
-
-(def-bignum-wrapper add-bignums (x y)
- (let ((res (funcall *old-add-bignums* x y)))
- (assert (big= (- res y) x))
- res))
-
-(def-bignum-wrapper multiply-bignums (x y)
- (let ((res (funcall *old-multiply-bignums* x y)))
- (if (zerop x)
- (assert (zerop res))
- (multiple-value-bind (q r) (truncate res x)
- (assert (and (zerop r) (big= q y)))))
- res))
-
-(def-bignum-wrapper negate-bignum (x &optional (fully-normalized t))
- (let ((res (funcall *old-negate-bignum* x fully-normalized)))
- (assert (big= (- res) x))
- res))
-
-(def-bignum-wrapper subtract-bignum (x y)
- (let ((res (funcall *old-subtract-bignum* x y)))
- (assert (big= (+ res y) x))
- res))
-
-(def-bignum-wrapper multiply-bignum-and-fixnum (x y)
- (let ((res (funcall *old-multiply-bignum-and-fixnum* x y)))
- (if (zerop x)
- (assert (zerop res))
- (multiple-value-bind (q r) (truncate res x)
- (assert (and (zerop r) (big= q y)))))
- res))
-
-(def-bignum-wrapper multiply-fixnums (x y)
- (let ((res (funcall *old-multiply-fixnums* x y)))
- (if (zerop x)
- (assert (zerop res))
- (multiple-value-bind (q r) (truncate res x)
- (assert (and (zerop r) (big= q y)))))
- res))
-
-(def-bignum-wrapper bignum-ashift-right (x shift)
- (let ((res (funcall *old-bignum-ashift-right* x shift)))
- (assert (big= (ash res shift) (logand x (ash -1 shift))))
- res))
-
-(def-bignum-wrapper bignum-ashift-left (x shift)
- (let ((res (funcall *old-bignum-ashift-left* x shift)))
- (assert (big= (ash res (- shift)) x))
- res))
-
-(def-bignum-wrapper bignum-truncate (x y)
- (multiple-value-bind (q r) (funcall *old-bignum-truncate* x y)
- (assert (big= (+ (* q y) r) x))
- (values q r)))
-
-(def-bignum-wrapper bignum-compare (x y)
- (let ((res (funcall *old-bignum-compare* x y)))
- (assert (big= (signum (- x y)) res))
- res))
echo $f | $sbcl < pure.lisp
done
-# *.test.sh files are scripts to test stuff. A file foo.test.sh
+# *.test.sh files are scripts to test stuff, typically stuff which can't
+# so easily be tested within Lisp itself. A file foo.test.sh
# may be associated with other files foo*, e.g. foo.lisp, foo-1.lisp,
# or foo.pl.
for f in *.test.sh; do
- sh $f
+ sh $f || exit failed test $f
+done
+
+# *.assertoids files contain ASSERTOID statements to test things
+# interpreted and at various compilation levels.
+for f in *.assertoids; do
+ echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")'
done
;;;
;;; Conventionally a string a la "0.6.6" is used for released
;;; versions, and a string a la "0.6.5.12" is used for versions which
-;;; aren't released but correspond only to CVS tags.
+;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.7.1"
+"0.6.7.2"
projects / sbcl.git / commitdiff