an error may be signalled at read time and it would be good if
SBCL did it.
- c: Reading of not initialized slot sometimes causes SEGV (for inline
- accessors it is fixed, but out-of-line still do not perform type
- check).
-
- d:
- (declaim (optimize (safety 3) (speed 1) (space 1)))
- (defstruct foo
- x y)
- (defstruct (stringwise-foo (:include foo
- (x "x" :type simple-string)
- (y "y" :type simple-string))))
- (defparameter *stringwise-foo*
- (make-stringwise-foo))
- (setf (foo-x *stringwise-foo*) 0)
- (defun frob-stringwise-foo (sf)
- (aref (stringwise-foo-x sf) 0))
- (frob-stringwise-foo *stringwise-foo*)
- SEGV.
+ d: (fixed in 0.8.1.5)
7:
The "compiling top-level form:" output ought to be condensed.
See also bugs #45.c and #183
-148:
- In sbcl-0.7.1.3 on x86, COMPILE-FILE on the file
- (in-package :cl-user)
- (defvar *thing*)
- (defvar *zoom*)
- (defstruct foo bar bletch)
- (defun %zeep ()
- (labels ((kidify1 (kid)
- )
- (kid-frob (kid)
- (if *thing*
- (setf sweptm
- (m+ (frobnicate kid)
- sweptm))
- (kidify1 kid))))
- (declare (inline kid-frob))
- (map nil
- #'kid-frob
- (the simple-vector (foo-bar perd)))))
- fails with
- debugger invoked on condition of type TYPE-ERROR:
- The value NIL is not of type SB-C::NODE.
- The location of this failure has moved around as various related
- issues were cleaned up. As of sbcl-0.7.1.9, it occurs in
- NODE-BLOCK called by LAMBDA-COMPONENT called by IR2-CONVERT-CLOSURE.
-
- (Python LET-converts KIDIFY1 into KID-FROB, then tries to inline
- expand KID-FROB into %ZEEP. Having partially done it, it sees a call
- of KIDIFY1, which already does not exist. So it gives up on
- expansion, leaving garbage consisting of infinished blocks of the
- partially converted function.)
-
- (due to reordering of the compiler this example is compiled
- successfully by 0.7.14, but the bug probably remains)
-
162:
(reported by Robert E. Brown 2002-04-16)
When a function is called with too few arguments, causing the
propagation or with SSA, but consider
(let ((x 0))
- (loop (if (random-boolean)
- (incf x 2)
- (incf x 5))))
+ (loop (incf x 2)))
- The careful type of X is {2k+5n} :-(. Is it really important to be
+ The careful type of X is {2k} :-(. Is it really important to be
able to work with unions of many intervals?
190: "PPC/Linux pipe? buffer? bug"
257:
Complex array type does not have corresponding type specifier.
+ This is a problem because the compiler emits optimization notes when
+ you use a non-simple array, and without a type specifier for hairy
+ array types, there's no good way to tell it you're doing it
+ intentionally so that it should shut up and just compile the code.
+
+ Another problem is confusing error message "asserted type ARRAY
+ conflicts with derived type (VALUES SIMPLE-VECTOR &OPTIONAL)" during
+ compiling (LAMBDA (V) (VALUES (SVREF V 0) (VECTOR-POP V))).
+
+ The last problem is that when type assertions are converted to type
+ checks, types are represented with type specifiers, so we could lose
+ complex attribute. (Now this is probably not important, because
+ currently checks for complex arrays seem to be performed by
+ callees.)
+
+259:
+ (compile nil '(lambda () (aref (make-array 0) 0))) compiles without
+ warning. Analogous cases with the index and length being equal and
+ greater than 0 are warned for; the problem here seems to be that the
+ type required for an array reference of this type is (INTEGER 0 (0))
+ which is canonicalized to NIL.
+
+260:
+ a.
+ (let* ((s (gensym))
+ (t1 (specifier-type s)))
+ (eval `(defstruct ,s))
+ (type= t1 (specifier-type s)))
+ => NIL, NIL
+
+ (fixed in 0.8.1.24)
+
+ b. The same for CSUBTYPEP.
+
+261:
+ * (let () (list (the (values &optional fixnum) (eval '(values)))))
+ debugger invoked on condition of type TYPE-ERROR:
+ The value NIL is not of type FIXNUM.
+
+262: "yet another bug in inline expansion of local functions"
+ Compiler fails on
+
+ (defun foo (x y)
+ (declare (integer x y))
+ (+ (block nil
+ (flet ((xyz (u)
+ (declare (integer u))
+ (if (> (1+ (the unsigned-byte u)) 0)
+ (+ 1 u)
+ (return (+ 38 (cos (/ u 78)))))))
+ (declare (inline xyz))
+ (return-from foo
+ (* (funcall (eval #'xyz) x)
+ (if (> x 30)
+ (funcall (if (> x 5) #'xyz #'identity)
+ (+ x 13))
+ 38)))))
+ (sin (* x y))))
+
+ Urgh... It's time to write IR1-copier.
+
+262:
+ In 0.8.1.32:
+
+ * (ensure-generic-function 'foo)
+ #<STANDARD-GENERIC-FUNCTION FOO (0)>
+ * (defmethod foo (x) x)
+ debugger invoked on condition of type SIMPLE-ERROR:
+ The generic function #<STANDARD-GENERIC-FUNCTION FOO (0)> takes 0 required
+ arguments; was asked to find a method with specializers (#<BUILT-IN-CLASS T>)
+
+ AMOP seems to say that it should work (first ADD-METHOD initializes
+ GF lambda list).
+
+263:
+ :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
+ PPRINT-LOGICAL-BLOCK may be complex strings.
+
+ (fixed in 0.8.1.33)
+
DEFUNCT CATEGORIES OF BUGS
IR1-#:
These labels were used for bugs related to the old IR1 interpreter.
functions defined in the same file. This also permits the system
to warn on static type mismatches and function
redefinition. (Currently it does not work with high DEBUG level.)
- * when issuing notes, the compiler now signals a condition of type
+ * minor incompatible change: VALUES declaration is disabled.
+ * When issuing notes, the compiler now signals a condition of type
SB-EXT:COMPILER-NOTE, and provides an associated MUFFLE-WARNING
restart for use in user handlers. It is expected that the
COMPILER-NOTE condition will eventually become a condition
supertype to a hierarchy of note types, which will then be
- handleable in a similar fashion; other than
- SB-INT:SIMPLE-COMPILER-NOTE, an implementation detail, no such
- note subtypes yet exist.
- * changes in type checking closed the following bugs:
+ handleable in a similar fashion. However, at the moment, no such
+ note subtypes yet exist. (SB-INT:SIMPLE-COMPILER-NOTE exists,
+ but it's an implementation detail, not a classification for the
+ purpose above.)
+ * Changes in type checking closed the following bugs:
** type checking of unused values (192b, 194d, 203);
** template selection based on unsafe type assertions (192c, 236);
** type checking in branches (194bc).
- * VALUES declaration is disabled.
- * a short form of VALUES type specifier has ANSI meaning (it has
+ * A short form of VALUES type specifier has ANSI meaning (it has
increased the number of situations when SBCL cannot perform type
checking).
* fixed bug in DEFSTRUCT: once again, naming structure slots with
outputs FRESH-LINE or TERPRI, and no longer converts its stream
argument to a pretty-print stream. Instead, it leaves any such
operations to DESCRIBE-OBJECT methods.
- * bug fix: APROPOS now respects the EXTERNAL-ONLY flag. (reported
+ * bug fix: APROPOS now respects the EXTERNAL-ONLY flag. (reported
by Teemu Kalvas)
* bug fix: NIL is now a valid destructuring argument in DEFMACRO
- lambda lists. (thanks to David Lichteblau)
- * bug fix: defining a generic function with a :METHOD-CLASS being a
+ lambda lists. (thanks to David Lichteblau)
+ * bug fix: Defining a generic function with a :METHOD-CLASS being a
subclass of STANDARD-METHOD no longer causes stack exhaustion.
(thanks to Gerd Moellmann)
* fixed bug 246: increased compilation speed of long
MULTIPLE-VALUE-BIND (and likewise of NTH-VALUE with a constant
- integer argument).
+ integer argument)
* a contributed module implementing COMPILER-LET and MACROEXPAND-ALL
has been included.
* DEFCONSTANT now throws a condition of type
SB-EXT:DEFCONSTANT-UNEQL if it is being asked to redefine a
constant to a non-EQL value; CONTINUE and ABORT restarts
- respectively change and preserve the value.
- * fixed bug 63: the code walker, part of the implementation of CLOS,
- is better at handling symbol macros.
- * bug fix: there is no longer a type named LENGTH. (reported by
- Raymond Toy)
- * bug fix: in macro-like defining macros/special operators the
- implicit block does not enclose lambda list.
- * fixed bugs 10 and 43: VALUES, AND, OR and MEMBER are not suitable as
- atomic type specifiers, and their use properly signals an error now.
- * bug fix: an argument count mismatch for a type specifier in code
+ respectively change and preserve the value.
+ * fixed bug 63: The code walker, part of the implementation of CLOS,
+ is now better at handling symbol macros.
+ * bug fix: There is no longer an internal implementation type named
+ CL:LENGTH. (reported by Raymond Toy)
+ * bug fix: In macro-like defining macros/special operators the
+ implicit block does not enclose the lambda list.
+ * fixed bugs 10 and 43: Bare VALUES, AND, OR and MEMBER symbols (not
+ enclosed in parentheses) are not suitable as type specifiers, and
+ their use properly signals an error now.
+ * bug fix: An argument count mismatch for a type specifier in code
being compiled no longer causes an unhandled error at compile
time, but signals a compile-time warning.
- * fixed simple vector readable printing.
+ * fixed simple vector readable printing
* bug fix: DESCRIBE takes more care over whether the class
precedence list slot of a class is bound before accessing it.
(reported by Markus Krummenacker)
* bug fix: FORMATTER can successfully compile pretty-printer format
strings which use variants of the ~* directive inside.
* bug fix: SEARCH now applies its TEST predicate to the elements of
- the arguments in the correct order. (thanks to Wolfhard Buss)
- * fixed bug 235b: compiler uses return types of MAPCAR and friends
- in type inference. (thanks to Robert E. Brown)
- * bug fix: reading in symbols with an explicit package name of ""
- (e.g. '||::FOO) now works corectly. (reported by Henrik Motakef)
+ the arguments in the correct order. (thanks to Wolfhard Buss)
+ * fixed bug 235b: The compiler uses return types of MAPCAR and friends
+ in type inference. (thanks to Robert E. Brown)
+ * bug fix: Reading in symbols with an explicit package name of ""
+ (e.g. '||::FOO) now works correctly. (reported by Henrik Motakef)
* fixed some bugs revealed by Paul Dietz' test suite:
** NIL is now allowed as a structure slot name.
- ** arbitrary numbers, not just reals, are allowed in certain
+ ** Arbitrary numbers, not just REALs, are allowed in certain
circumstances in LOOP for-as-arithmetic clauses.
- ** multiple class redefinitions before slot access no longer
+ ** Multiple class redefinitions before slot access no longer
causes a type error.
** (SETF FIND-CLASS) now accepts NIL as an argument to remove the
association between the name and a class.
- ** generic functions with non-standard method-combination and over
+ ** Generic functions with non-standard method-combination and over
five methods all of which return constants no longer return NIL
- after the first few invocations. (thanks to Gerd Moellmann)
+ after the first few invocations. (thanks to Gerd Moellmann)
** CALL-NEXT-METHOD with no arguments now passes the original
values of the arguments, even in the presence of assignment.
- ** functions [N]SUBST*, LAST, NRECONC, [N]SUBLIS may return any
+ ** Functions [N]SUBST*, LAST, NRECONC, [N]SUBLIS may return any
object.
** DISASSEMBLE works with closures and funcallable instances.
- ** ADD-METHOD now returns the generic function, not the new
- method.
+ ** ADD-METHOD now returns the generic function, not the new method.
** FIND-METHOD signals an error if the lengths of the specializers
is incompatible with the generic function, even if the ERRORP
argument is true.
treated by SLOT-BOUNDP, SLOT-VALUE, (SETF SLOT-VALUE) and
SLOT-MAKUNBOUND in the specified fashion.
+changes in sbcl-0.8.2 relative to sbcl-0.8.1:
+ * fixed bug 148: failure to inline-expand a local function left
+ garbage, confusing the compiler.
+ * fixed bugs 3cd: structure slot readers perform type check if the
+ slot can have an invalid value (i.e. it is either not initialized
+ or can be written with a less specific slot writer).
+ * bug fix: the compiler now traps array references to elements off
+ the end of an array; previously, the bounds checking in some
+ circumstances could go off-by-one.
+ * improved MACHINE-VERSION, especially on Linux (thanks to Lars
+ Brinkhoff)
+ * type declarations for array element types now obey the description
+ on the CLHS page "Declaration TYPE", as per discussions on
+ sbcl-help around 2003-05-08. This means that a declaration
+ (TYPE (ARRAY FOO) BAR) means that, within the scope of the
+ declaration, all references to BAR will be asserted or assumed
+ (with THE, so dependent on compiler policy) to involve objects of
+ type FOO. Note that no such declaration is implied in
+ (MAKE-ARRAY .. :ELEMENT-TYPE 'FOO).
+ * declared types of functions from the "Conditions"
+ chapter. (reported by Paul Dietz)
+ * bug fix: CERROR accepts a function as its first argument.
+ * bug fix: NTH an NTHCDR accept a bignum as index
+ arguments. (reported by Adam Warner)
+ * optimization: character compare routines now optimize comparing
+ against a constant character. (reported by Gilbert Baumann)
+ * bug fix: (SETF AREF) on byte-sized-element arrays with constant index
+ argument now works properly on the MIPS platform.
+ * fixed compiler failure on (TYPEP x '(NOT (MEMBER 0d0))).
+ * repeated evaluation of the same DEFSTRUCT, a slot of which is
+ declared to have a functional type, does not cause an error
+ anymore.
+ * fixed bug: sometimes MAKE-INSTANCE did not work with classes with
+ many :DEFAULT-INITARGS. (reported by Istvan Marko)
+ * fixed bug: if last continuation of a deleted block has a
+ destination, this destination should be deleted too. (reported by
+ ohler on #lisp)
+ * fixed some bugs revealed by Paul Dietz' test suite:
+ ** LAST and [N]BUTLAST should accept a bignum.
+ ** condition slot accessors are methods.
+
planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
down, it might impact TRACE. They both encapsulate functions, and
* On X86 I is represented as a tagged integer.
-* EQL uses "CMP reg,reg" instead of "CMP reg,im". This causes
- allocation of an extra register and an extra move.
-
* Unnecessary move:
3: SLOT S!11[EDX] {SB-C::VECTOR-LENGTH 1 7} => t23[EAX]
4: MOVE t23[EAX] => t24[EBX]
memory location for iteration variable
;;; -*- mode: lisp -*-
-;;; $Id$
;;; http://www.bagley.org/~doug/shootout/
;;; from Friedrich Dominicus
(if Y were used only once, the current compiler would optimize it)
--------------------------------------------------------------------------------
+#12
+(typep (truly-the (simple-array * (*)) x) 'simple-vector)
+
+tests lowtag.
+--------------------------------------------------------------------------------
+#13
+FAST-+/FIXNUM and similar should accept unboxed arguments in interests
+of representation selection. Problem: inter-TN dependencies.
+--------------------------------------------------------------------------------
;;; supplied by basic machinery
("src/code/cross-misc" :not-target)
+ ("src/code/cross-char" :not-target)
("src/code/cross-byte" :not-target)
("src/code/cross-float" :not-target)
("src/code/cross-io" :not-target)
Q4) Is this compatible with ACL? With CMUCL's internet.lisp?
A4) No. This is a sufficiently low-level interface that either could
-be built on top of it, though. Actually, theq ACL-COMPAT library that
+be built on top of it, though. Actually, the ACL-COMPAT library that
comes with Portable Allegroserve may already have this.
o/~ Hey Mr Tambourine Man, play some -*- Text -*- for me o/~
A semi-sane sockets interface for SBCL. Usually also works in CMUCL,
-but is rarely actually tested there so may require some massaging
-
-See INSTALL for prerequisites and build details
-
-It uses the regression tester from the CMU AI repository. This is
-bundled in the file rt.lisp which is unchanged except where I added a
-DEFPACKAGE form. The tests themselves are in tests.lisp, and can be
-run using the Makefile target intended for the purpose, or by
-evaluating (rt:do-tests). Note that one of the tests is an HTTP
-client that connects back to ww.telent.net; if this bothers your
-expectations of privacy, don't run it.
+but is rarely actually tested there so may require some massaging.
+
+It is invoked through the SBCL contrib/ modules system:
+ (require :asdf)
+ (require :sb-bsd-sockets)
+
+It uses the regression tester from the CMU AI repository, in its
+incarnation as the SBCL contrib SB-RT. The tests themselves are in
+tests.lisp, and can be run using the Makefile target intended for the
+purpose, or by evaluating (sb-rt:do-tests). Note that one of the tests
+is an HTTP client that connects back to ww.telent.net; if this bothers
+your expectations of privacy, don't run it.
There is an automatically generated API reference in
api-reference.html which you can regenerate if you can figure out how
#-sunos
(deftest simple-local-client
(let ((s (make-instance 'local-socket :type :datagram)))
- (format t "~A~%" s)
- (socket-connect s "/dev/log")
+ (format t "Connecting ~A... " s)
+ (finish-output)
+ (handler-case
+ (socket-connect s "/dev/log")
+ (sb-bsd-sockets::socket-error ()
+ (setq s (make-instance 'local-socket :type :stream))
+ (format t "failed~%Retrying with ~A... " s)
+ (finish-output)
+ (socket-connect s "/dev/log")))
+ (format t "ok.~%")
(let ((stream (socket-make-stream s :input t :output t :buffering :none)))
(format stream
"<7>bsd-sockets: Don't panic. We're testing local-domain client code; this message can safely be ignored")
t)
-;;; these require that the internet (or bits of it, atleast) is available
+;;; these require that the internet (or bits of it, at least) is available
#+internet-available
(deftest get-host-by-name
--- /dev/null
+(in-package "SB-ROTATE-BYTE")
+
+(define-vop (%32bit-rotate-byte/c)
+ (:policy :fast-safe)
+ (:translate %unsigned-32-rotate-byte)
+ (:note "inline 32-bit constant rotation")
+ (:info count)
+ (:args (integer :scs (sb-vm::unsigned-reg) :target res))
+ (:arg-types (:constant (integer -31 31)) sb-vm::unsigned-byte-32)
+ (:results (res :scs (sb-vm::unsigned-reg)))
+ (:result-types sb-vm::unsigned-byte-32)
+ (:generator 5
+ ;; the 0 case is an identity operation and should be
+ ;; DEFTRANSFORMed away.
+ (aver (not (= count 0)))
+ (if (> count 0)
+ (inst rotlwi res integer count)
+ (inst rotrwi res integer (- count)))))
+
+(define-vop (%32bit-rotate-byte-fixnum/c)
+ (:policy :fast-safe)
+ (:translate %unsigned-32-rotate-byte)
+ (:note "inline 32-bit constant rotation")
+ (:info count)
+ (:args (integer :scs (sb-vm::any-reg) :target res))
+ (:arg-types (:constant (integer -31 31)) sb-vm::positive-fixnum)
+ (:results (res :scs (sb-vm::unsigned-reg)))
+ (:result-types sb-vm::unsigned-byte-32)
+ (:generator 5
+ (aver (not (= count 0)))
+ (cond
+ ;; FIXME: all these 2s should be n-fixnum-tag-bits.
+ ((= count 2))
+ ((> count 2) (inst rotlwi res integer (- count 2)))
+ (t (inst rotrwi res integer (- 2 count))))))
+
+(macrolet ((def (name arg-type)
+ `(define-vop (,name)
+ (:policy :fast-safe)
+ (:translate %unsigned-32-rotate-byte)
+ (:note "inline 32-bit rotation")
+ (:args (count :scs (sb-vm::signed-reg))
+ (integer :scs (sb-vm::unsigned-reg) :target res))
+ (:arg-types sb-vm::tagged-num ,arg-type)
+ (:temporary (:scs (sb-vm::unsigned-reg) :from (:argument 0))
+ realcount)
+ (:results (res :scs (sb-vm::unsigned-reg)))
+ (:result-types sb-vm::unsigned-byte-32)
+ (:generator 10
+ (let ((label (gen-label))
+ (end (gen-label)))
+ (inst cmpwi count 0)
+ (inst bge label)
+ (inst addi realcount count 32)
+ (inst rotlw res integer realcount)
+ (inst b end)
+ (emit-label label)
+ (inst rotlw res integer count)
+ (emit-label end))))))
+ (def %32bit-rotate-byte sb-vm::unsigned-byte-32)
+ ;; FIXME: see x86-vm.lisp
+ (def %32bit-rotate-byte-fixnum sb-vm::positive-fixnum))
(defsystem sb-rotate-byte
:version "0.1"
- :components ((:file "package")
- (:file "compiler" :depends-on ("package"))
- (:module "vm"
- :depends-on ("compiler")
- :components ((:file "x86-vm"
- :in-order-to ((compile-op (feature :x86)))))
- :pathname #.(make-pathname :directory '(:relative))
- :if-component-dep-fails :ignore)
- (:file "rotate-byte" :depends-on ("compiler"))))
+ :components
+ ((:file "package")
+ (:file "compiler" :depends-on ("package"))
+ (:module "vm"
+ :depends-on ("compiler")
+ :components
+ ((:file "x86-vm"
+ :in-order-to ((compile-op (feature :x86))))
+ (:file "ppc-vm"
+ :in-order-to ((compile-op (feature :ppc)))))
+ :pathname #.(make-pathname :directory '(:relative))
+ :if-component-dep-fails :ignore)
+ (:file "rotate-byte" :depends-on ("compiler"))))
(defmethod perform :after ((o load-op) (c (eql (find-system :sb-rotate-byte))))
(provide 'sb-rotate-byte))
between multiple Lisp processes. is less important with modern
generational garbage collectors. </para>
-<para>The <function>sb-ext:truly-the</> operator does what the
-<function>cl:the</> operator does in a more conventional
-implementation of &CommonLisp;, declaring the type of its argument
-without any runtime checks. (Ordinarily in &SBCL;, any type
-declaration is treated as an assertion and checked at runtime.)</para>
+<para>The <function>sb-ext:truly-the</> declares the type of the
+result of the operations, producing its argument; the declaration is
+not checked. In short: don't use it.</para>
<para>The <function>sb-ext:freeze-type</> declaration declares that a
type will never change, which can make type testing
is <emphasis>not</> appropriate for functions like <function>aref</>,
which can change their return values when the underlying data are
changed.</para>
+<!-- FIXME: This declaration does not seem to be supported in the --
+ -- current compiler. -->
</sect2>
</sect1>
-</chapter>
\ No newline at end of file
+</chapter>
Ideally, the compiler would consider <emphasis>all</> type declarations to
be assertions, so that adding type declarations to a program, no
matter how incorrect they might be, would <emphasis>never</> cause
-undefined behavior. As of &SBCL; version 0.6.4, the compiler is known to
+undefined behavior. As of &SBCL; version 0.8.1, the compiler is known to
fall short of this goal in two areas:
<itemizedlist>
- <listitem><para>The compiler trusts function return values which
- have been established with <function>proclaim</>.</para></listitem>
+ <listitem><para><function>Proclaim</>ed constraints on argument and
+ result types of a function are supposed to be checked by the
+ function. If the function type is proclaimed before function
+ definition, type checks are inserted by the compiler, but the
+ standard allows the reversed order, in which case the compiler
+ will trust the declaration.</para></listitem>
+ <listitem><para>The compiler cannot check types of an unknown number
+ of values; if the number of generated values is unknown, but the
+ number of consumed is known, only consumed values are
+ checked.</para></listitem>
<listitem><para>There are a few poorly characterized but apparently
very uncommon situations where a type declaration in an unexpected
location will be trusted and never checked by the
<para>
Type warnings are inhibited when the
-<parameter>extensions:inhibit-warnings</> optimization quality is
-<literal>3</>. (See <link linkend="compiler-policy">the section
+<parameter>sb-ext:inhibit-warnings</> optimization quality is
+<literal>3</>. (See <link linkend="compiler-policy">the section
on compiler policy</>.) This can be used in a local declaration
to inhibit type warnings in a code fragment that has spurious
warnings.</para>
<!--INDEX {type checking}{precise}-->
<para>With the default compilation policy, all type declarations are
-precisely checked, except in a few situations (such as using
-<function>the</> to constrain the argument type passed to a function)
-where they are simply ignored instead. Precise checking means that the
-check is done as though <function>typep</> had been called with the
-exact type specifier that appeared in the declaration. In &SBCL;,
-adding type declarations makes code safer. (Except that as noted <link
-linkend="compiler-impl-limitations">elsewhere</link>, remaining bugs in
-the compiler's handling of types unfortunately provide some exceptions to
-this rule.)</para>
+precisely checked, except in a few situations where they are simply
+ignored instead. Precise checking means that the check is done as
+though <function>typep</> had been called with the exact type
+specifier that appeared in the declaration. In &SBCL;, adding type
+declarations makes code safer. (Except that as noted <link
+linkend="compiler-impl-limitations">elsewhere</link>, remaining bugs
+in the compiler's handling of types unfortunately provide some
+exceptions to this rule.)</para>
<para>If a variable is declared to be
-<type>(integer 3 17)</>
-then its
-value must always always be an integer between <literal>3</>
-and <literal>17</>.
-If multiple type declarations apply to a single variable, then all the
-declarations must be correct; it is as though all the types were
-intersected producing a single <type>and</> type specifier.</para>
-
-<para>Argument type declarations are automatically enforced. If you declare
-the type of a function argument, a type check will be done when that
-function is called. In a function call, the called function does the
-argument type checking, which means that a more restrictive type
-assertion in the calling function (e.g., from <function>the</>) may be
-lost.</para>
+<type>(integer 3 17)</> then its value must always be an integer
+between <literal>3</> and <literal>17</>. If multiple type
+declarations apply to a single variable, then all the declarations
+must be correct; it is as though all the types were intersected
+producing a single <type>and</> type specifier.</para>
+
+<para>Argument and result type declarations are automatically
+enforced. If you declare the type of a function argument, a type check
+will be done when that function is called. In a function call, the
+called function does the argument type checking.</para>
<para>The types of structure slots are also checked. The value of a
structure slot must always be of the type indicated in any
(This doesn't affect its ability to benefit from explicit type
declarations involving the assigned variables, only its ability to
get by without explicit type declarations.)</para></listitem>
+<!-- FIXME: Python dislikes assignments, but not in type
+ inference. The real problems are loop induction, closed over
+ variables and aliases. -->
<listitem><para>Since the time the &CMUCL; manual was written,
&CMUCL; (and thus &SBCL;) has gotten a generational garbage
collector. This means that there are some efficiency implications
exit 1
fi
printf ":%s" "$sbcl_arch" >> $ltf
-# KLUDGE: currently the x86 only works with the generational garbage
-# collector (indicated by the presence of :GENCGC in *FEATURES*) and
-# alpha, sparc and ppc with the stop'n'copy collector (indicated by
-# the absence of :GENCGC in *FEATURES*). This isn't a great
-# separation, but for now, rather than have :GENCGC in
-# base-target-features.lisp-expr, we add it into local-target-features
-# if we're building for x86. -- CSR, 2002-02-21 Then we do something
-# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
-if [ "$sbcl_arch" = "x86" ] ; then
- printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
-elif [ "$sbcl_arch" = "mips" ] ; then
- # Use a little C program to try to guess the endianness. Ware
- # cross-compilers!
- $GNUMAKE -C tools-for-build determine-endianness
- tools-for-build/determine-endianness >> $ltf
-else
- # Nothing need be done in this case, but sh syntax wants a placeholder.
- echo > /dev/null
-fi
+
for d in src/compiler src/assembly; do
echo //setting up symlink $d/target
original_dir=`pwd`
esac
cd $original_dir
+# KLUDGE: currently the x86 only works with the generational garbage
+# collector (indicated by the presence of :GENCGC in *FEATURES*) and
+# alpha, sparc and ppc with the stop'n'copy collector (indicated by
+# the absence of :GENCGC in *FEATURES*). This isn't a great
+# separation, but for now, rather than have :GENCGC in
+# base-target-features.lisp-expr, we add it into local-target-features
+# if we're building for x86. -- CSR, 2002-02-21 Then we do something
+# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
+if [ "$sbcl_arch" = "x86" ] ; then
+ printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
+elif [ "$sbcl_arch" = "mips" ] ; then
+ # Use a little C program to try to guess the endianness. Ware
+ # cross-compilers!
+ $GNUMAKE -C tools-for-build determine-endianness
+ tools-for-build/determine-endianness >> $ltf
+else
+ # Nothing need be done in this case, but sh syntax wants a placeholder.
+ echo > /dev/null
+fi
+
echo //finishing $ltf
echo ')' >> $ltf
sh make-host-2.sh || exit 1
sh make-target-2.sh || exit 1
sh make-target-contrib.sh || exit 1
+
+# Sometimes people used to see the "No tests failed." output from the last
+# DEFTEST in contrib self-tests and thing that's all that is. So...
+echo
+echo The build seems to have finished successfully. If you would like
+echo run more extensive tests on the new SBCL, you can try
+echo " cd tests && sh ./run-tests.sh."
+echo "(but expect some failures on non-x86 platforms)."
+
date
"EVAL-IN-LEXENV"
"DEBUG-NAMIFY"
"FORCE" "DELAY" "PROMISE-READY-P"
+ "FIND-RESTART-OR-CONTROL-ERROR"
;; These could be moved back into SB!EXT if someone has
;; compelling reasons, but hopefully we can get by
"FIND-AND-INIT-OR-CHECK-LAYOUT"
"FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME"
"FLOAT-FORMAT-MAX" "FLOATING-POINT-EXCEPTION"
- "FORM" "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P"
+ "FORM"
+ "FORMAT-CONTROL"
+ "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P"
"FUN-CODE-HEADER"
"FUN-TYPE" "FUN-TYPE-ALLOWP"
"FUN-TYPE-KEYP" "FUN-TYPE-KEYWORDS"
"GENERALIZED-BOOLEAN"
"GET-CLOSURE-LENGTH"
"GET-HEADER-DATA"
- "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF"
- "WIDETAG-OF"
+ "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF" "WIDETAG-OF"
+ "GET-MACHINE-VERSION"
"HAIRY-DATA-VECTOR-REF" "HAIRY-DATA-VECTOR-SET" "HAIRY-TYPE"
"HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER"
"HANDLE-CIRCULARITY" "HOST" "IGNORE-IT"
#!+x86 "*PSEUDO-ATOMIC-INTERRUPTED*"
"PUNT-PRINT-IF-TOO-LONG"
"READER-IMPOSSIBLE-NUMBER-ERROR" "READER-PACKAGE-ERROR"
+ "RESTART-DESIGNATOR"
"SCALE-DOUBLE-FLOAT"
#!+long-float "SCALE-LONG-FLOAT"
"SCALE-SINGLE-FLOAT"
"VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP"
"VALUES-TYPE"
"VALUES-TYPE-ERROR"
+ "VALUES-TYPE-IN"
"VALUES-TYPE-INTERSECTION"
"VALUES-TYPE-OPTIONAL"
+ "VALUES-TYPE-OUT"
"VALUES-TYPE-P" "VALUES-TYPE-REQUIRED"
"VALUES-TYPE-REST" "VALUES-TYPE-UNION"
"VALUES-TYPE-TYPES" "VALUES-TYPES"
- "VALUES-TYPE-START"
"VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P"
"VECTOR-NIL-P"
"VECTOR-TO-VECTOR*"
(defun machine-type ()
"Return a string describing the type of the local machine."
"Alpha")
-(defun machine-version ()
- "Return a string describing the version of the local machine."
- "Alpha")
+
+;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
+(defun get-machine-version ()
+ nil)
\f
(defun fixup-code-object (code offset value kind)
(unless (zerop (rem offset n-word-bytes))
(bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?"))
\f
;;;; MAKE-ARRAY
-(defun upgraded-array-element-type (spec &optional environment)
- #!+sb-doc
- "Return the element type that will actually be used to implement an array
- with the specifier :ELEMENT-TYPE Spec."
- (declare (ignore environment))
- (if (unknown-type-p (specifier-type spec))
- (error "undefined type: ~S" spec)
- (type-specifier (array-type-specialized-element-type
- (specifier-type `(array ,spec))))))
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro pick-vector-type (type &rest specs)
`(cond ,@(mapcar (lambda (spec)
(let ((index (car subs))
(dim (%array-dimension array axis)))
(declare (fixnum dim))
- (unless (< -1 index dim)
+ (unless (and (fixnump index) (< -1 index dim))
(if invalid-index-error-p
(error 'simple-type-error
:format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S"
(setf chunk-size (* chunk-size dim))))
(let ((index (first subscripts))
(length (length (the (simple-array * (*)) array))))
- (unless (< -1 index length)
+ (unless (and (fixnump index) (< -1 index length))
(if invalid-index-error-p
;; FIXME: perhaps this should share a format-string
;; with INVALID-ARRAY-INDEX-ERROR or
(defun array-in-bounds-p (array &rest subscripts)
#!+sb-doc
- "Return T if the Subscipts are in bounds for the Array, Nil otherwise."
+ "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
(if (%array-row-major-index array subscripts nil)
t))
(defun aref (array &rest subscripts)
#!+sb-doc
- "Return the element of the Array specified by the Subscripts."
+ "Return the element of the ARRAY specified by the SUBSCRIPTS."
(row-major-aref array (%array-row-major-index array subscripts)))
(defun %aset (array &rest stuff)
(defvar *cold-init-forms*))
(defmacro !begin-collecting-cold-init-forms ()
- #-sb-xc-host '(eval-when (:compile-toplevel :execute)
- (when (boundp '*cold-init-forms*)
- (warn "discarding old *COLD-INIT-FORMS* value"))
- (setf *cold-init-forms* nil))
- #+sb-xc-host nil)
+ #+sb-xc '(eval-when (:compile-toplevel :execute)
+ (when (boundp '*cold-init-forms*)
+ (warn "discarding old *COLD-INIT-FORMS* value"))
+ (setf *cold-init-forms* nil))
+ #-sb-xc nil)
;;; Note: Unlike the analogous COLD-INIT macro in CMU CL, this macro
;;; makes no attempt to simulate a top level situation by treating
;; In the target Lisp, stuff the forms into a named function which
;; will presumably be executed at the appropriate stage of cold load
;; (i.e. basically as soon as possible).
- #-sb-xc-host (progn
- (setf *cold-init-forms*
- (nconc *cold-init-forms* (copy-list forms)))
- nil)
+ #+sb-xc (progn
+ (setf *cold-init-forms*
+ (nconc *cold-init-forms* (copy-list forms)))
+ nil)
;; In the cross-compilation host Lisp, cold load might not be a
;; meaningful concept and in any case would have happened long ago,
;; so just execute the forms at load time (i.e. basically as soon as
;; possible).
- #+sb-xc-host `(let () ,@forms))
+ #-sb-xc `(progn ,@forms))
(defmacro !defun-from-collected-cold-init-forms (name)
- #-sb-xc-host `(progn
- (defun ,name ()
- ,@*cold-init-forms*
- (values))
- (eval-when (:compile-toplevel :execute)
- (makunbound '*cold-init-forms*)))
- #+sb-xc-host (declare (ignore name)))
+ #+sb-xc `(progn
+ (defun ,name ()
+ ,@*cold-init-forms*
+ (values))
+ (eval-when (:compile-toplevel :execute)
+ (makunbound '*cold-init-forms*)))
+ #-sb-xc (declare (ignore name)))
;;; FIXME: Consider renaming this file asap.lisp,
;;; and the renaming the various things
(res (copy-structure sslot)))))))
(res)))
+;;; Early definitions of slot accessor creators.
+;;;
+;;; Slot accessors must be generic functions, but ANSI does not seem
+;;; to specify any of them, and we cannot support it before end of
+;;; warm init. So we use ordinary functions inside SBCL, and switch to
+;;; GFs only at the end of building.
+(declaim (notinline install-condition-slot-reader
+ install-condition-slot-writer))
+(defun install-condition-slot-reader (name condition slot-name)
+ (declare (ignore condition))
+ (setf (fdefinition name)
+ (lambda (condition)
+ (condition-reader-function condition slot-name))))
+(defun install-condition-slot-writer (name condition slot-name)
+ (declare (ignore condition))
+ (setf (fdefinition name)
+ (lambda (new-value condition)
+ (condition-writer-function condition new-value slot-name))))
+
(defun %define-condition (name slots documentation report default-initargs)
(let ((class (find-classoid name)))
(setf (condition-classoid-slots class) slots)
(dolist (slot slots)
;; Set up reader and writer functions.
- (let ((name (condition-slot-name slot)))
+ (let ((slot-name (condition-slot-name slot)))
(dolist (reader (condition-slot-readers slot))
- (setf (fdefinition reader)
- (lambda (condition)
- (condition-reader-function condition name))))
+ (install-condition-slot-reader reader name slot-name))
(dolist (writer (condition-slot-writers slot))
- (setf (fdefinition writer)
- (lambda (new-value condition)
- (condition-writer-function condition new-value name))))))
+ (install-condition-slot-writer writer name slot-name))))
;; Compute effective slots and set up the class and hairy slots
;; (subsets of the effective slots.)
#!+sb-doc
"Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
none exists."
- (invoke-restart (find-restart 'abort condition))
+ (invoke-restart (find-restart-or-control-error 'abort condition))
;; ABORT signals an error in case there was a restart named ABORT
;; that did not transfer control dynamically. This could happen with
;; RESTART-BIND.
#!+sb-doc
"Transfer control to a restart named MUFFLE-WARNING, signalling a
CONTROL-ERROR if none exists."
- (invoke-restart (find-restart 'muffle-warning condition)))
+ (invoke-restart (find-restart-or-control-error 'muffle-warning condition)))
(macrolet ((define-nil-returning-restart (name args doc)
#!-sb-doc (declare (ignore doc))
--- /dev/null
+;;;; cross-compile-time-only replacements for unportable character
+;;;; stuff
+
+;;;; 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!IMPL")
+
+(let ((ascii-standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"))
+ (defun sb!xc:code-char (x)
+ (declare (type (or (integer 10 10) (integer 32 126)) x))
+ (if (= x 10)
+ #\Newline
+ (char ascii-standard-chars (- x 32))))
+ (defun sb!xc:char-code (character)
+ (declare (type standard-char character))
+ ;; FIXME: MacOS X?
+ (if (char= character #\Newline)
+ 10
+ (+ (position character ascii-standard-chars) 32))))
(let ((inherited (accessor-inherited-data name defstruct)))
(cond
((not inherited)
- (stuff `(proclaim '(inline ,name (setf ,name))))
+ (stuff `(declaim (inline ,name (setf ,name))))
;; FIXME: The arguments in the next two DEFUNs should
;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
;; be the name of a special variable, things could get
(dsd-index included-slot))
(dd-inherited-accessor-alist dd)
:test #'eq :key #'car))
- (parse-1-dsd dd
- modified
- (copy-structure included-slot)))))))
+ (let ((new-slot (parse-1-dsd dd
+ modified
+ (copy-structure included-slot))))
+ (when (and (neq (dsd-type new-slot) (dsd-type included-slot))
+ (not (subtypep (dsd-type included-slot)
+ (dsd-type new-slot)))
+ (dsd-safe-p included-slot))
+ (setf (dsd-safe-p new-slot) nil)
+ ;; XXX: notify?
+ )))))))
\f
;;;; various helper functions for setting up DEFSTRUCTs
;;; semistandard types
(sb!xc:deftype generalized-boolean () t)
+(sb!xc:deftype format-control ()
+ '(or string function))
+
+(sb!xc:deftype restart-designator ()
+ '(or (and symbol (not null)) restart))
+
;;; array rank, total size...
(sb!xc:deftype array-rank () `(integer 0 (,sb!xc:array-rank-limit)))
(sb!xc:deftype array-total-size ()
"~&~@<Its REHASH-SIZE is ~S. ~_Its REHASH-THRESHOLD is ~S.~:>"
(hash-table-rehash-size x)
(hash-table-rehash-threshold x))
- (fresh-line)
+ (fresh-line s)
(pprint-logical-block (s nil)
(let ((count (hash-table-count x)))
(format s "It holds ~S key/value pair~:P~:[: ~2I~_~;.~]"
(error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG?
:value value
:expected-type type
- :format-string "~@<~S ~_is not a ~_~S~:>"
+ :format-control "~@<~S ~_is not a ~_~S~:>"
:format-arguments (list value type)))
\f
;;; Return a function like FUN, but expecting its (two) arguments in
:rest rest
:allowp allowp))
-;;; FIXME: ANSI VALUES has a short form (without lambda list
-;;; keywords), which should be translated into a long one.
(defun make-values-type (&key (args nil argsp)
required optional rest allowp)
(if argsp
;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
(defstruct (fun-type (:include args-type
(class-info (type-class-or-lose 'function)))
- (:constructor %make-fun-type))
+ (:constructor
+ %make-fun-type (&key required optional rest
+ keyp keywords allowp
+ wild-args
+ returns
+ &aux (rest (if (eq rest *empty-type*)
+ nil
+ rest)))))
;; true if the arguments are unrestrictive, i.e. *
(wild-args nil :type boolean)
;; type describing the return values. This is a values type
(define-condition simple-stream-error (simple-condition stream-error) ())
(define-condition simple-parse-error (simple-condition parse-error) ())
-;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
-;;; compiler warnings can be emitted as appropriate.
-(define-condition parse-unknown-type (condition)
- ((specifier :reader parse-unknown-type-specifier :initarg :specifier)))
-
(define-condition control-stack-exhausted (storage-condition)
()
(:report
(type definition))
(:copier nil))
;; This is definition's encapsulation type. The encapsulated
- ;; definition is in the previous encapsulation-info element or
+ ;; definition is in the previous ENCAPSULATION-INFO element or
;; installed as the global definition of some function name.
type
;; the previous, encapsulated definition. This used to be installed
;; an encapsulation that no longer exists.
(let ((info (make-encapsulation-info type (fdefn-fun fdefn))))
(setf (fdefn-fun fdefn)
- (lambda (&rest arg-list)
+ (named-lambda encapsulate (&rest arg-list)
(declare (special arg-list))
(let ((basic-definition (encapsulation-info-definition info)))
(declare (special basic-definition))
;;; When removing an encapsulation, we must remember that
;;; encapsulating definitions close over a reference to the
-;;; encapsulation-info that describes the encapsulating definition.
+;;; ENCAPSULATION-INFO that describes the encapsulating definition.
;;; When you find an info with the target type, the previous info in
;;; the chain has the ensulating definition of that type. We take the
;;; encapsulated definition from the info with the target type, and we
(unless (zerop possible-result)
(return possible-result)))))
+;;; Dan Barlow's quick summary from IRC 2003-06-21:
+;;; fwiw, load-foreign does random stuff with ld so that you can use
+;;; it with static libraries
+;;; if you have shared objects, load-1-foreign will do fine
+;;; and
+;;; I think my position on this matter is consistent with Tim Moore's:
+;;; use (cmucl equivalent of) load-1-foreign, load-foreign is arse
+;;; though he may say ass
(defun load-foreign (files
&key
(libraries '("-lc"))
"Returns a string describing the type of the local machine."
"HPPA")
-(defun machine-version ()
- "Returns a string describing the version of the local machine."
- "HPPA")
-
+;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
+(defun get-machine-version ()
+ nil)
\f
;;;; FIXUP-CODE-OBJECT
(sb!xc:defmacro def-math-rtn (name num-args)
(let ((function (symbolicate "%" (string-upcase name))))
`(progn
- (proclaim '(inline ,function))
+ (declaim (inline ,function))
(sb!alien:define-alien-routine (,name ,function) double-float
,@(let ((results nil))
(dotimes (i num-args (nreverse results))
--- /dev/null
+;;;; Condition support in target lisp
+
+;;;; 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-KERNEL")
+\f
+(fmakunbound 'install-condition-slot-reader)
+(fmakunbound 'install-condition-slot-writer)
+(defun install-condition-slot-reader (name condition slot-name)
+ (unless (fboundp name)
+ (ensure-generic-function name :lambda-list '(condition)))
+ (eval `(defmethod ,name ((.condition. ,condition))
+ (condition-reader-function .condition. ',slot-name))))
+(defun install-condition-slot-writer (name condition slot-name)
+ (unless (fboundp name)
+ (ensure-generic-function name :lambda-list '(new-value condition)))
+ (eval `(defmethod ,name (new-value (.condition. ,condition))
+ (condition-writer-function .condition. new-value ',slot-name))))
;;; There are all sorts of nasty problems with open bounds on FLOAT
;;; types (and probably FLOAT types in general.)
+;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
+;;; compiler warnings can be emitted as appropriate.
+(define-condition parse-unknown-type (condition)
+ ((specifier :reader parse-unknown-type-specifier :initarg :specifier)))
+
;;; FIXME: This really should go away. Alas, it doesn't seem to be so
;;; simple to make it go away.. (See bug 123 in BUGS file.)
(defvar *use-implementation-types* t ; actually initialized in cold init
(return (values nil t))))))
(!define-type-method (values :simple-=) (type1 type2)
- (let ((rest1 (args-type-rest type1))
- (rest2 (args-type-rest type2)))
- (cond ((and rest1 rest2 (type/= rest1 rest2))
- (type= rest1 rest2))
- ((or rest1 rest2)
- (values nil t))
- (t
- (multiple-value-bind (req-val req-win)
- (type=-list (values-type-required type1)
- (values-type-required type2))
- (multiple-value-bind (opt-val opt-win)
- (type=-list (values-type-optional type1)
- (values-type-optional type2))
- (values (and req-val opt-val) (and req-win opt-win))))))))
+ (type=-args type1 type2))
(!define-type-class function)
((fun-type-wild-args type1)
(cond ((fun-type-keyp type2) (values nil nil))
((not (fun-type-rest type2)) (values nil t))
- ((not (null (fun-type-required type2))) (values nil t))
- (t (and/type (type= *universal-type* (fun-type-rest type2))
- (every/type #'type= *universal-type*
- (fun-type-optional type2))))))
+ ((not (null (fun-type-required type2)))
+ (values nil t))
+ (t (and/type (type= *universal-type*
+ (fun-type-rest type2))
+ (every/type #'type=
+ *universal-type*
+ (fun-type-optional
+ type2))))))
((not (and (fun-type-simple-p type1)
(fun-type-simple-p type2)))
(values nil nil))
(cond ((or (> max1 max2) (< min1 min2))
(values nil t))
((and (= min1 min2) (= max1 max2))
- (and/type (every-csubtypep (fun-type-required type1)
- (fun-type-required type2))
- (every-csubtypep (fun-type-optional type1)
- (fun-type-optional type2))))
+ (and/type (every-csubtypep
+ (fun-type-required type1)
+ (fun-type-required type2))
+ (every-csubtypep
+ (fun-type-optional type1)
+ (fun-type-optional type2))))
(t (every-csubtypep
(concatenate 'list
(fun-type-required type1)
(declare (ignore type1 type2))
(specifier-type 'function))
(!define-type-method (function :simple-intersection2) (type1 type2)
- (declare (ignore type1 type2))
- (specifier-type 'function))
+ (let ((ftype (specifier-type 'function)))
+ (cond ((eq type1 ftype) type2)
+ ((eq type2 ftype) type1)
+ (t (let ((rtype (values-type-intersection (fun-type-returns type1)
+ (fun-type-returns type2))))
+ (flet ((change-returns (ftype rtype)
+ (declare (type fun-type ftype) (type ctype rtype))
+ (make-fun-type :required (fun-type-required ftype)
+ :optional (fun-type-optional ftype)
+ :keyp (fun-type-keyp ftype)
+ :keywords (fun-type-keywords ftype)
+ :allowp (fun-type-allowp ftype)
+ :returns rtype)))
+ (cond
+ ((fun-type-wild-args type1)
+ (if (fun-type-wild-args type2)
+ (make-fun-type :wild-args t
+ :returns rtype)
+ (change-returns type2 rtype)))
+ ((fun-type-wild-args type2)
+ (change-returns type1 rtype))
+ (t (multiple-value-bind (req opt rest)
+ (args-type-op type1 type2 #'type-intersection #'max)
+ (make-fun-type :required req
+ :optional opt
+ :rest rest
+ ;; FIXME: :keys
+ :allowp (and (fun-type-allowp type1)
+ (fun-type-allowp type2))
+ :returns rtype))))))))))
;;; The union or intersection of a subclass of FUNCTION with a
;;; FUNCTION type is somewhat complicated.
(values nil t))
((eq (fun-type-wild-args type1) t)
(values t t))
- (t (and/type
- (cond ((null (fun-type-rest type1))
- (values (null (fun-type-rest type2)) t))
- ((null (fun-type-rest type2))
- (values nil t))
- (t
- (compare type= rest)))
- (labels ((type-list-= (l1 l2)
- (cond ((null l1)
- (values (null l2) t))
- ((null l2)
- (values nil t))
- (t (multiple-value-bind (res winp)
- (type= (first l1) (first l2))
- (cond ((not winp)
- (values nil nil))
- ((not res)
- (values nil t))
- (t
- (type-list-= (rest l1)
- (rest l2)))))))))
- (and/type (and/type (compare type-list-= required)
- (compare type-list-= optional))
- (if (or (fun-type-keyp type1) (fun-type-keyp type2))
- (values nil nil)
- (values t t))))))))))
+ (t (type=-args type1 type2))))))
(!define-type-class constant :inherits values)
(cond ((args-type-rest type))
(t default-type)))))
-;;; If COUNT values are supplied, which types should they have?
-(defun values-type-start (type count)
+;;; types of values in (the <type> (values o_1 ... o_n))
+(defun values-type-out (type count)
(declare (type ctype type) (type unsigned-byte count))
(if (eq type *wild-type*)
(make-list count :initial-element *universal-type*)
do (res rest))))
(res))))
+;;; types of variable in (m-v-bind (v_1 ... v_n) (the <type> ...
+(defun values-type-in (type count)
+ (declare (type ctype type) (type unsigned-byte count))
+ (if (eq type *wild-type*)
+ (make-list count :initial-element *universal-type*)
+ (collect ((res))
+ (let ((null-type (specifier-type 'null)))
+ (loop for type in (values-type-required type)
+ while (plusp count)
+ do (decf count)
+ do (res type))
+ (loop for type in (values-type-optional type)
+ while (plusp count)
+ do (decf count)
+ do (res (type-union type null-type)))
+ (when (plusp count)
+ (loop with rest = (acond ((values-type-rest type)
+ (type-union it null-type))
+ (t null-type))
+ repeat count
+ do (res rest))))
+ (res))))
+
;;; Return a list of OPERATION applied to the types in TYPES1 and
;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
;;; than TYPES2. The second value is T if OPERATION always returned a
(length (args-type-required type2))))
(required (subseq res 0 req))
(opt (subseq res req)))
- (values (make-values-type
- :required required
- :optional opt
- :rest rest)
+ (values required opt rest
(and rest-exact res-exact))))))))
+(defun values-type-op (type1 type2 operation nreq)
+ (multiple-value-bind (required optional rest exactp)
+ (args-type-op type1 type2 operation nreq)
+ (values (make-values-type :required required
+ :optional optional
+ :rest rest)
+ exactp)))
+
+(defun type=-args (type1 type2)
+ (macrolet ((compare (comparator field)
+ (let ((reader (symbolicate '#:args-type- field)))
+ `(,comparator (,reader type1) (,reader type2)))))
+ (and/type
+ (cond ((null (args-type-rest type1))
+ (values (null (args-type-rest type2)) t))
+ ((null (args-type-rest type2))
+ (values nil t))
+ (t
+ (compare type= rest)))
+ (and/type (and/type (compare type=-list required)
+ (compare type=-list optional))
+ (if (or (args-type-keyp type1) (args-type-keyp type2))
+ (values nil nil)
+ (values t t))))))
+
;;; Do a union or intersection operation on types that might be values
;;; types. The result is optimized for utility rather than exactness,
;;; but it is guaranteed that it will be no smaller (more restrictive)
((eq type1 *empty-type*) type2)
((eq type2 *empty-type*) type1)
(t
- (values (args-type-op type1 type2 #'type-union #'min)))))
+ (values (values-type-op type1 type2 #'type-union #'min)))))
(defun-cached (values-type-intersection :hash-function type-cache-hash
:hash-bits 8
:rest (values-type-rest type1)
:allowp (values-type-allowp type1))))
(t
- (args-type-op type1 (coerce-to-values type2)
- #'type-intersection
- #'max))))
+ (values-type-op type1 (coerce-to-values type2)
+ #'type-intersection
+ #'max))))
;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
;;; works on VALUES types. Note that due to the semantics of
(values nil nil))
(!define-type-method (hairy :complex-=) (type1 type2)
- (declare (ignore type1 type2))
- (values nil nil))
+ (if (and (unknown-type-p type2)
+ (let* ((specifier2 (unknown-type-specifier type2))
+ (name2 (if (consp specifier2)
+ (car specifier2)
+ specifier2)))
+ (info :type :kind name2)))
+ (let ((type2 (specifier-type (unknown-type-specifier type2))))
+ (if (unknown-type-p type2)
+ (values nil nil)
+ (type= type1 type2)))
+ (values nil nil)))
(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
(type1 type2)
((consp low-bound)
(let ((low-value (car low-bound)))
(or (eql low-value high-bound)
- (and (eql low-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql high-bound 0f0))
- (and (eql low-value 0f0) (eql high-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
- (and (eql low-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql high-bound 0d0))
- (and (eql low-value 0d0) (eql high-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
+ (and (eql low-value
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero)))
+ (eql high-bound 0f0))
+ (and (eql low-value 0f0)
+ (eql high-bound
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero))))
+ (and (eql low-value
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))
+ (eql high-bound 0d0))
+ (and (eql low-value 0d0)
+ (eql high-bound
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))))))
((consp high-bound)
(let ((high-value (car high-bound)))
(or (eql high-value low-bound)
- (and (eql high-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql low-bound 0f0))
- (and (eql high-value 0f0) (eql low-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
- (and (eql high-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql low-bound 0d0))
- (and (eql high-value 0d0) (eql low-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
+ (and (eql high-value
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero)))
+ (eql low-bound 0f0))
+ (and (eql high-value 0f0)
+ (eql low-bound
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero))))
+ (and (eql high-value
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))
+ (eql low-bound 0d0))
+ (and (eql high-value 0d0)
+ (eql low-bound
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))))))
((and (eq (numeric-type-class low) 'integer)
(eq (numeric-type-class high) 'integer))
(eql (1+ low-bound) high-bound))
(mapcar (lambda (x y) (if (eq x '*) y x))
dims1 dims2)))
:complexp (if (eq complexp1 :maybe) complexp2 complexp1)
- :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1))))
+ :element-type (cond
+ ((eq eltype1 *wild-type*) eltype2)
+ ((eq eltype2 *wild-type*) eltype1)
+ (t (type-intersection eltype1 eltype2))))))
*empty-type*))
;;; Check a supplied dimension list to determine whether it is legal,
(in-package "SB!IMPL")
+;;; Limitation: no list might have more than INDEX conses.
+
;;;; KLUDGE: comment from CMU CL, what does it mean?
;;;; NSUBLIS, things at the beginning broken.
;;;; -- WHN 20000127
(cdr list))
(defun nthcdr (n list)
- (declare (type index n))
#!+sb-doc
"Performs the cdr function n times on a list."
- (do ((i n (1- i))
- (result list (cdr result)))
- ((not (plusp i)) result)
- (declare (type index i))))
+ (flet ((fast-nthcdr (n list)
+ (declare (type index n))
+ (do ((i n (1- i))
+ (result list (cdr result)))
+ ((not (plusp i)) result)
+ (declare (type index i)))))
+ (typecase n
+ (index (fast-nthcdr n list))
+ (t (do ((i 0 (1+ i))
+ (r-i list (cdr r-i))
+ (r-2i list (cddr r-2i)))
+ ((and (eq r-i r-2i) (not (zerop i)))
+ (fast-nthcdr (mod n i) r-i))
+ (declare (type index i)))))))
(defun last (list &optional (n 1))
#!+sb-doc
"Return the last N conses (not the last element!) of a list."
- (declare (type index n))
- (do ((checked-list list (cdr checked-list))
- (returned-list list)
- (index 0 (1+ index)))
- ((atom checked-list) returned-list)
- (declare (type index index))
- (if (>= index n)
- (pop returned-list))))
+ (if (typep n 'index)
+ (do ((checked-list list (cdr checked-list))
+ (returned-list list)
+ (index 0 (1+ index)))
+ ((atom checked-list) returned-list)
+ (declare (type index index))
+ (if (>= index n)
+ (pop returned-list)))
+ list))
(defun list (&rest args)
#!+sb-doc
(declare (type index result)))))
(declare (ftype (function (t) index) count-conses))
(defun butlast (list &optional (n 1))
- (let ((n-conses-in-list (count-conses list)))
- (cond ((zerop n)
- ;; (We can't use SUBSEQ in this case because LIST isn't
- ;; necessarily a proper list, but SUBSEQ expects a
- ;; proper sequence. COPY-LIST isn't so fussy.)
- (copy-list list))
- ((>= n n-conses-in-list)
- nil)
- (t
- ;; (LIST isn't necessarily a proper list in this case
- ;; either, and technically SUBSEQ wants a proper
- ;; sequence, but no reasonable implementation of SUBSEQ
- ;; will actually walk down to the end of the list to
- ;; check, and since we're calling our own implementation
- ;; we know it's reasonable, so it's OK.)
- (subseq list 0 (- n-conses-in-list n))))))
+ (if (typep n 'index)
+ (let ((n-conses-in-list (count-conses list)))
+ (cond ((zerop n)
+ ;; (We can't use SUBSEQ in this case because LIST isn't
+ ;; necessarily a proper list, but SUBSEQ expects a
+ ;; proper sequence. COPY-LIST isn't so fussy.)
+ (copy-list list))
+ ((>= n n-conses-in-list)
+ nil)
+ (t
+ ;; (LIST isn't necessarily a proper list in this case
+ ;; either, and technically SUBSEQ wants a proper
+ ;; sequence, but no reasonable implementation of SUBSEQ
+ ;; will actually walk down to the end of the list to
+ ;; check, and since we're calling our own implementation
+ ;; we know it's reasonable, so it's OK.)
+ (subseq list 0 (- n-conses-in-list n)))))
+ nil))
(defun nbutlast (list &optional (n 1))
- (if (zerop n)
- list
- (let ((n-conses-in-list (count-conses list)))
- (unless (<= n-conses-in-list n)
- (setf (cdr (nthcdr (- n-conses-in-list n 1) list))
- nil)
- list)))))
+ (cond ((zerop n)
+ list)
+ ((not (typep n 'index))
+ nil)
+ (t (let ((n-conses-in-list (count-conses list)))
+ (unless (<= n-conses-in-list n)
+ (setf (cdr (nthcdr (- n-conses-in-list n 1) list))
+ nil)
+ list))))))
(defun ldiff (list object)
"Return a new list, whose elements are those of LIST that appear before
;;; Set the Nth element of LIST to NEWVAL.
(defun %setnth (n list newval)
- (declare (type index n))
- (do ((count n (1- count))
- (list list (cdr list)))
- ((endp list)
- (error "~S is too large an index for SETF of NTH." n))
- (declare (type fixnum count))
- (when (<= count 0)
- (rplaca list newval)
- (return newval))))
+ (typecase n
+ (index
+ (do ((count n (1- count))
+ (list list (cdr list)))
+ ((endp list)
+ (error "~S is too large an index for SETF of NTH." n))
+ (declare (type fixnum count))
+ (when (<= count 0)
+ (rplaca list newval)
+ (return newval))))
+ (t (let ((cons (nthcdr n list)))
+ (when (endp cons)
+ (error "~S is too large an index for SETF of NTH." n))
+ (rplaca cons newval)
+ newval))))
\f
;;;; :KEY arg optimization to save funcall of IDENTITY
"Returns a string describing the type of the local machine."
"MIPS")
-(defun machine-version ()
- "Returns a string describing the version of the local machine."
+;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
+(defun get-machine-version ()
#!+little-endian "little-endian"
#!-little-endian "big-endian")
-
\f
;;;; FIXUP-CODE-OBJECT
(if (consp x)
(let ((name (car x)))
(if (eq name 'declaim)
- (progn (style-warn
- "DECLAIM is met where DECLARE is expected.")
- nil)
+ ;; technically legal, but rather unlikely to
+ ;; be what the user intended...
+ (progn
+ (style-warn
+ "DECLAIM where DECLARE was probably intended")
+ nil)
(eq name 'declare))))))
(tagbody
:again
"Returns a string describing the type of the local machine."
"PowerPC")
-(defun machine-version ()
- "Returns a string describing the version of the local machine."
- "who-knows?")
-
-
+;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
+(defun get-machine-version ()
+ #!+linux
+ (with-open-file (stream "/proc/cpuinfo"
+ ;; /proc is optional even in Linux, so
+ ;; fail gracefully.
+ :if-does-not-exist nil)
+ (loop with line while (setf line (read-line stream nil))
+ ;; hoping "cpu" exists and gives something useful in
+ ;; all relevant Linuxen...
+ ;;
+ ;; from Lars Brinkhoff sbcl-devel 26 Jun 2003:
+ ;; I examined different versions of Linux/PPC at
+ ;; http://lxr.linux.no/ (the file that outputs
+ ;; /proc/cpuinfo is arch/ppc/kernel/setup.c, if
+ ;; you want to check), and all except 2.0.x
+ ;; seemed to do the same thing as far as the
+ ;; "cpu" field is concerned, i.e. it always
+ ;; starts with the (C-syntax) string "cpu\t\t: ".
+ when (eql (search "cpu" line) 0)
+ return (string-trim " " (subseq line (1+ (position #\: line))))))
+ #!-linux
+ nil)
\f
;;;; FIXUP-CODE-OBJECT
;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
;; :PREFIX and :PER-LINE-PREFIX have hairy defaulting behavior,
;; and might end up being NIL.)
- (declare (type (or null string prefix)))
+ (declare (type (or null string) prefix))
;; (But the defaulting behavior of PPRINT-LOGICAL-BLOCK :SUFFIX is
;; trivial, so it should always be a string.)
(declare (type string suffix))
(when prefix
+ (setq prefix (coerce prefix 'simple-string))
(pretty-sout stream prefix 0 (length prefix)))
(let* ((pending-blocks (pretty-stream-pending-blocks stream))
(start (enqueue stream block-start
:prefix (and per-line-p prefix)
- :suffix suffix
+ :suffix (coerce suffix 'simple-string)
:depth (length pending-blocks))))
(setf (pretty-stream-pending-blocks stream)
(cons start pending-blocks))))
(index index)
(step (reduce #'* dims))
(count 0))
- (loop
+ (loop
(pprint-pop)
(output-guts stream index dims)
(when (= (incf count) dim)
'((start end length sequence)
(start1 end1 length1 sequence1)
(start2 end2 length2 sequence2)))
+ (key nil
+ nil
+ (and key (%coerce-callable-to-fun key))
+ (or null function))
+ (test #'eql
+ nil
+ (%coerce-callable-to-fun test)
+ function)
+ (test-not nil
+ nil
+ (and test-not (%coerce-callable-to-fun test-not))
+ (or null function))
))
(sb!xc:defmacro define-sequence-traverser (name args &body body)
(sb!xc:defmacro vector-nreverse (sequence)
`(let ((length (length (the vector ,sequence))))
- (declare (fixnum length))
- (do ((left-index 0 (1+ left-index))
- (right-index (1- length) (1- right-index))
- (half-length (truncate length 2)))
- ((= left-index half-length) ,sequence)
- (declare (fixnum left-index right-index half-length))
- (rotatef (aref ,sequence left-index)
- (aref ,sequence right-index)))))
+ (when (>= length 2)
+ (do ((left-index 0 (1+ left-index))
+ (right-index (1- length) (1- right-index)))
+ ((<= right-index left-index))
+ (declare (type index left-index right-index))
+ (rotatef (aref ,sequence left-index)
+ (aref ,sequence right-index))))
+ ,sequence))
(sb!xc:defmacro list-nreverse-macro (list)
`(do ((1st (cdr ,list) (if (endp 1st) 1st (cdr 1st)))
) ; EVAL-WHEN
(define-sequence-traverser delete
- (item sequence &key from-end (test #'eql) test-not start
+ (item sequence &key from-end test test-not start
end count key)
#!+sb-doc
"Return a sequence formed by destructively removing the specified ITEM from
) ; EVAL-WHEN
(define-sequence-traverser remove
- (item sequence &key from-end (test #'eql) test-not start
+ (item sequence &key from-end test test-not start
end count key)
#!+sb-doc
"Return a copy of SEQUENCE with elements satisfying the test (default is
(shrink-vector result jndex)))
(define-sequence-traverser remove-duplicates
- (sequence &key (test #'eql) test-not (start 0) end from-end key)
+ (sequence &key test test-not start end from-end key)
#!+sb-doc
"The elements of SEQUENCE are compared pairwise, and if any two match,
the one occurring earlier is discarded, unless FROM-END is true, in
(setq jndex (1+ jndex)))))
(define-sequence-traverser delete-duplicates
- (sequence &key (test #'eql) test-not (start 0) end from-end key)
+ (sequence &key test test-not start end from-end key)
#!+sb-doc
"The elements of SEQUENCE are examined, and if any two match, one is
discarded. The resulting sequence, which may be formed by destroying the
) ; EVAL-WHEN
(define-sequence-traverser substitute
- (new old sequence &key from-end (test #'eql) test-not
+ (new old sequence &key from-end test test-not
start count end key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements,
;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
(define-sequence-traverser substitute-if
- (new test sequence &key from-end start end count key)
+ (new pred sequence &key from-end start end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
- except that all elements satisfying the TEST are replaced with NEW. See
+ except that all elements satisfying the PRED are replaced with NEW. See
manual for details."
(declare (fixnum start))
(let ((end (or end length))
+ (test pred)
test-not
old)
(declare (type index length end))
(subst-dispatch 'if)))
(define-sequence-traverser substitute-if-not
- (new test sequence &key from-end start end count key)
+ (new pred sequence &key from-end start end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
- except that all elements not satisfying the TEST are replaced with NEW.
+ except that all elements not satisfying the PRED are replaced with NEW.
See manual for details."
(declare (fixnum start))
(let ((end (or end length))
+ (test pred)
test-not
old)
(declare (type index length end))
;;;; NSUBSTITUTE
(define-sequence-traverser nsubstitute
- (new old sequence &key from-end (test #'eql) test-not
+ (new old sequence &key from-end test test-not
end count key start)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
(define-sequence-traverser nsubstitute-if
- (new test sequence &key from-end start end count key)
+ (new pred sequence &key from-end start end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
- except that all elements satisfying the TEST are replaced with NEW.
+ except that all elements satisfying the PRED are replaced with NEW.
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
(let ((end (or end length)))
(if from-end
(let ((length (length sequence)))
(nreverse (nlist-substitute-if*
- new test (nreverse (the list sequence))
+ new pred (nreverse (the list sequence))
(- length end) (- length start) count key)))
- (nlist-substitute-if* new test sequence
+ (nlist-substitute-if* new pred sequence
start end count key))
(if from-end
- (nvector-substitute-if* new test sequence -1
+ (nvector-substitute-if* new pred sequence -1
(1- end) (1- start) count key)
- (nvector-substitute-if* new test sequence 1
+ (nvector-substitute-if* new pred sequence 1
start end count key)))))
(defun nlist-substitute-if* (new test sequence start end count key)
(setq count (1- count)))))
(define-sequence-traverser nsubstitute-if-not
- (new test sequence &key from-end start end count key)
+ (new pred sequence &key from-end start end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements not satisfying the TEST are replaced with NEW.
(if from-end
(let ((length (length sequence)))
(nreverse (nlist-substitute-if-not*
- new test (nreverse (the list sequence))
+ new pred (nreverse (the list sequence))
(- length end) (- length start) count key)))
- (nlist-substitute-if-not* new test sequence
+ (nlist-substitute-if-not* new pred sequence
start end count key))
(if from-end
- (nvector-substitute-if-not* new test sequence -1
+ (nvector-substitute-if-not* new pred sequence -1
(1- end) (1- start) count key)
- (nvector-substitute-if-not* new test sequence 1
+ (nvector-substitute-if-not* new pred sequence 1
start end count key)))))
(defun nlist-substitute-if-not* (new test sequence start end count key)
) ; EVAL-WHEN
-(define-sequence-traverser count-if (test sequence &key from-end start end key)
+(define-sequence-traverser count-if (pred sequence &key from-end start end key)
#!+sb-doc
- "Return the number of elements in SEQUENCE satisfying TEST(el)."
+ "Return the number of elements in SEQUENCE satisfying PRED(el)."
(declare (fixnum start))
(let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
(if from-end
- (list-count-if nil t test sequence)
- (list-count-if nil nil test sequence))
+ (list-count-if nil t pred sequence)
+ (list-count-if nil nil pred sequence))
(if from-end
- (vector-count-if nil t test sequence)
- (vector-count-if nil nil test sequence)))))
+ (vector-count-if nil t pred sequence)
+ (vector-count-if nil nil pred sequence)))))
(define-sequence-traverser count-if-not
- (test sequence &key from-end start end key)
+ (pred sequence &key from-end start end key)
#!+sb-doc
"Return the number of elements in SEQUENCE not satisfying TEST(el)."
(declare (fixnum start))
(declare (type index end))
(seq-dispatch sequence
(if from-end
- (list-count-if t t test sequence)
- (list-count-if t nil test sequence))
+ (list-count-if t t pred sequence)
+ (list-count-if t nil pred sequence))
(if from-end
- (vector-count-if t t test sequence)
- (vector-count-if t nil test sequence)))))
+ (vector-count-if t t pred sequence)
+ (vector-count-if t nil pred sequence)))))
(define-sequence-traverser count
(item sequence &key from-end start end
(define-sequence-traverser mismatch
(sequence1 sequence2
- &key from-end (test #'eql) test-not
+ &key from-end test test-not
start1 end1 start2 end2 key)
#!+sb-doc
"The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
`(do ((main ,main (cdr main))
(jndex start1 (1+ jndex))
(sub (nthcdr start1 ,sub) (cdr sub)))
- ((or (null main) (null sub) (= (the fixnum end1) jndex))
+ ((or (endp main) (endp sub) (<= end1 jndex))
t)
- (declare (fixnum jndex))
+ (declare (type (integer 0) jndex))
(compare-elements (car sub) (car main))))
(sb!xc:defmacro search-compare-list-vector (main sub)
`(do ((main ,main (cdr main))
(index start1 (1+ index)))
- ((or (null main) (= index (the fixnum end1))) t)
- (declare (fixnum index))
+ ((or (endp main) (= index end1)) t)
(compare-elements (aref ,sub index) (car main))))
(sb!xc:defmacro search-compare-vector-list (main sub index)
`(do ((sub (nthcdr start1 ,sub) (cdr sub))
(jndex start1 (1+ jndex))
(index ,index (1+ index)))
- ((or (= (the fixnum end1) jndex) (null sub)) t)
- (declare (fixnum jndex index))
+ ((or (<= end1 jndex) (endp sub)) t)
+ (declare (type (integer 0) jndex))
(compare-elements (car sub) (aref ,main index))))
(sb!xc:defmacro search-compare-vector-vector (main sub index)
`(do ((index ,index (1+ index))
(sub-index start1 (1+ sub-index)))
- ((= sub-index (the fixnum end1)) t)
- (declare (fixnum sub-index index))
+ ((= sub-index end1) t)
(compare-elements (aref ,sub sub-index) (aref ,main index))))
(sb!xc:defmacro search-compare (main-type main sub index)
(sb!xc:defmacro list-search (main sub)
`(do ((main (nthcdr start2 ,main) (cdr main))
(index2 start2 (1+ index2))
- (terminus (- (the fixnum end2)
- (the fixnum (- (the fixnum end1)
- (the fixnum start1)))))
+ (terminus (- end2 (the (integer 0) (- end1 start1))))
(last-match ()))
((> index2 terminus) last-match)
- (declare (fixnum index2 terminus))
+ (declare (type (integer 0) index2))
(if (search-compare list main ,sub index2)
(if from-end
(setq last-match index2)
(sb!xc:defmacro vector-search (main sub)
`(do ((index2 start2 (1+ index2))
- (terminus (- (the fixnum end2)
- (the fixnum (- (the fixnum end1)
- (the fixnum start1)))))
+ (terminus (- end2 (the (integer 0) (- end1 start1))))
(last-match ()))
((> index2 terminus) last-match)
- (declare (fixnum index2 terminus))
+ (declare (type (integer 0) index2))
(if (search-compare vector ,main ,sub index2)
(if from-end
(setq last-match index2)
(define-sequence-traverser search
(sequence1 sequence2
- &key from-end (test #'eql) test-not
+ &key from-end test test-not
start1 end1 start2 end2 key)
(declare (fixnum start1 start2))
(let ((end1 (or end1 length1))
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
-
\f
-
;;; See x86-vm.lisp for a description of this.
(define-alien-type os-context-t (struct os-context-t-struct))
-
-
\f
;;;; MACHINE-TYPE and MACHINE-VERSION
"Returns a string describing the type of the local machine."
"SPARC")
-(defun machine-version ()
- "Returns a string describing the version of the local machine."
- "SPARC")
-
+;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
+(defun get-machine-version ()
+ nil)
\f
(defun fixup-code-object (code offset fixup kind)
(declare (type index offset))
;; private predicate function..) is ugly and confusing, but
;; I can't see any other way. -- WHN 2001-04-14
:expected-type '(satisfies stream-associated-with-file-p)
- :format-string
+ :format-control
"~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
:format-arguments (list stream))))
;;; strings in the unasterisked versions and using this in the
;;; transforms conditional on SAFETY>SPEED,SPACE).
(defun %check-vector-sequence-bounds (vector start end)
- (declare (type vector vector)
- (type index start)
- (type (or index null) end))
- (let ((length (length vector)))
- (if (<= 0 start (or end length) length)
- (or end length)
- (signal-bounding-indices-bad-error string start end))))
+ (%check-vector-sequence-bounds vector start end))
(eval-when (:compile-toplevel)
;;; WITH-ONE-STRING is used to set up some string hacking things. The
;; through here.
(%slotplace-accessor-funs (slotplace instance-type-check-form)
(/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form)
- `(values (lambda (instance)
- (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
- ,instance-type-check-form
- (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
- ,slotplace)
- (let ((typecheckfun (typespec-typecheckfun dsd-type)))
- (lambda (new-value instance)
+ `(let ((typecheckfun (typespec-typecheckfun dsd-type)))
+ (values (if (dsd-safe-p dsd)
+ (lambda (instance)
+ (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
+ ,instance-type-check-form
+ (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+ ,slotplace)
+ (lambda (instance)
+ (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
+ ,instance-type-check-form
+ (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+ (let ((value ,slotplace))
+ (funcall typecheckfun value)
+ value)))
+ (lambda (new-value instance)
(/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer")
,instance-type-check-form
(/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
(let ((dsd-index (dsd-index dsd))
(dsd-type (dsd-type dsd)))
-
+
#+sb-xc (/show0 "got DSD-TYPE=..")
#+sb-xc (/hexstr dsd-type)
(ecase (dd-type dd)
(structure
#+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE")
(%native-slot-accessor-funs %instance-ref))
-
+
;; structures with the :TYPE option
;; FIXME: Worry about these later..
(eq (restart-name x) name)))
restarts)))
-(defun find-restart-or-lose (restart-designator)
- (let ((real-restart (find-restart restart-designator)))
- (unless real-restart
+;;; helper for the various functions which are ANSI-spec'ed to do
+;;; something with a restart or signal CONTROL-ERROR if there is none
+(defun find-restart-or-control-error (identifier &optional condition)
+ (or (find-restart identifier condition)
(error 'simple-control-error
- :format-control "Restart ~S is not active."
- :format-arguments (list restart-designator)))
- real-restart))
+ :format-control "No restart ~S is active ~{for ~S~}."
+ :format-arguments (list identifier condition))))
(defun invoke-restart (restart &rest values)
#!+sb-doc
"Calls the function associated with the given restart, passing any given
arguments. If the argument restart is not a restart or a currently active
- non-nil restart name, then a control-error is signalled."
+ non-nil restart name, then a CONTROL-ERROR is signalled."
(/show "entering INVOKE-RESTART" restart)
- (let ((real-restart (find-restart-or-lose restart)))
+ (let ((real-restart (find-restart-or-control-error restart)))
(apply (restart-function real-restart) values)))
(defun interactive-restart-arguments (real-restart)
#!+sb-doc
"Calls the function associated with the given restart, prompting for any
necessary arguments. If the argument restart is not a restart or a
- currently active non-nil restart name, then a control-error is signalled."
- (let* ((real-restart (find-restart-or-lose restart))
+ currently active non-NIL restart name, then a CONTROL-ERROR is signalled."
+ (let* ((real-restart (find-restart-or-control-error restart))
(args (interactive-restart-arguments real-restart)))
(apply (restart-function real-restart) args)))
\f
"Return a string giving the name of the local machine."
(sb!unix:unix-gethostname))
+(defvar *machine-version*)
+
+(defun machine-version ()
+ #!+sb-doc
+ "Return a string describing the version of the computer hardware we
+are running on, or NIL if we can't find any useful information."
+ (unless (boundp '*machine-version*)
+ (setf *machine-version* (get-machine-version)))
+ *machine-version*)
+
;;; FIXME: Don't forget to set these in a sample site-init file.
;;; FIXME: Perhaps the functions could be SETFable instead of having the
;;; interface be through special variables? As far as I can tell
values-subtypep-cache-clear
csubtypep-cache-clear
type-intersection2-cache-clear
- values-type-intersection-cache-clear))
+ values-type-intersection-cache-clear
+ type=-cache-clear))
(funcall (the function (symbol-function sym)))))
(values))
"Return a string describing the type of the local machine."
"X86")
-(defun machine-version ()
- #!+sb-doc
- "Return a string describing the version of the local machine."
- "X86")
+;;; arch-specific support for CL:MACHINE-VERSION, defined OAOO elsewhere
+(defun get-machine-version ()
+ #!+linux
+ (with-open-file (stream "/proc/cpuinfo"
+ ;; Even on Linux it's an option to build
+ ;; kernels without /proc filesystems, so
+ ;; degrade gracefully.
+ :if-does-not-exist nil)
+ (loop with line while (setf line (read-line stream nil))
+ ;; The field "model name" exists on kernel 2.4.21-rc6-ac1
+ ;; anyway, with values e.g.
+ ;; "AMD Athlon(TM) XP 2000+"
+ ;; "Intel(R) Pentium(R) M processor 1300MHz"
+ ;; which seem comparable to the information in the example
+ ;; in the MACHINE-VERSION page of the ANSI spec.
+ when (eql (search "model name" line) 0)
+ return (string-trim " " (subseq line (1+ (position #\: line))))))
+ #!-linux
+ nil)
\f
;;;; :CODE-OBJECT fixups
;; existence in xc and target
"BUILT-IN-CLASS"
"BYTE" "BYTE-POSITION" "BYTE-SIZE"
+ "CHAR-CODE"
"CLASS" "CLASS-NAME" "CLASS-OF"
+ "CODE-CHAR"
"COMPILE-FILE"
"COMPILE-FILE-PATHNAME"
"*COMPILE-FILE-PATHNAME*"
"STRUCTURE-CLASS"
"SUBTYPEP"
"TYPE-OF" "TYPEP"
+ "UPGRADED-ARRAY-ELEMENT-TYPE"
"WITH-COMPILATION-UNIT"))
(export (intern name package-name) package-name)))
;; don't watch:
;; miscellaneous functionality which depends on CLOS
"src/code/force-delayed-defbangmethods"
+ "src/code/late-condition"
;; CLOS-level support for the Gray OO streams
;; extension (which is also supported by various
(inst bne temp target)
(inst beq temp target))))
-(defun %test-lowtag-and-headers (value target not-p lowtag
- function-p headers &key temp)
- (let ((drop-through (gen-label)))
- (%test-lowtag value (if not-p drop-through target) nil lowtag :temp temp)
- (%test-headers value target not-p function-p headers
- :drop-through drop-through :temp temp)))
-
(defun %test-headers (value target not-p function-p headers
&key (drop-through (gen-label)) temp)
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
;; 2002-08-21
*wild-type*)))
+(defun extract-declared-element-type (array)
+ (let ((type (continuation-type array)))
+ (if (array-type-p type)
+ (array-type-element-type type)
+ *wild-type*)))
+
;;; The ``new-value'' for array setters must fit in the array, and the
;;; return type is going to be the same as the new-value for SETF
;;; functions.
`(,(if simple 'simple-array 'array)
,(cond ((not element-type) t)
((constant-continuation-p element-type)
- (continuation-value element-type))
+ (let ((ctype (careful-specifier-type
+ (continuation-value element-type))))
+ (cond
+ ((or (null ctype) (unknown-type-p ctype)) '*)
+ (t (sb!xc:upgraded-array-element-type
+ (continuation-value element-type))))))
(t
'*))
,(cond ((constant-continuation-p dims)
(len (if (constant-continuation-p length)
(continuation-value length)
'*))
- (result-type-spec `(simple-array ,eltype (,len)))
(eltype-type (ir1-transform-specifier-type eltype))
+ (result-type-spec
+ `(simple-array
+ ,(if (unknown-type-p eltype-type)
+ (give-up-ir1-transform
+ "ELEMENT-TYPE is an unknown type: ~S" eltype)
+ (sb!xc:upgraded-array-element-type eltype))
+ (,len)))
(saetp (find-if (lambda (saetp)
(csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
sb!vm:*specialized-array-element-type-properties*)))
(rank (length dims))
(spec `(simple-array
,(cond ((null element-type) t)
- ((constant-continuation-p element-type)
- (continuation-value element-type))
+ ((and (constant-continuation-p element-type)
+ (ir1-transform-specifier-type
+ (continuation-value element-type)))
+ (sb!xc:upgraded-array-element-type
+ (continuation-value element-type)))
(t '*))
,(make-list rank :initial-element '*))))
`(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
(give-up-ir1-transform))
(t
(let ((dim (continuation-value dimension)))
- `(the (integer 0 ,dim) index)))))
+ `(the (integer 0 (,dim)) index)))))
\f
;;;; WITH-ARRAY-DATA
;;; value?
\f
;;; Pick off some constant cases.
-(deftransform array-header-p ((array) (array))
+(defoptimizer (array-header-p derive-type) ((array))
(let ((type (continuation-type array)))
- (unless (array-type-p type)
- (give-up-ir1-transform))
- (let ((dims (array-type-dimensions type)))
- (cond ((csubtypep type (specifier-type '(simple-array * (*))))
- ;; no array header
- nil)
- ((and (listp dims) (/= (length dims) 1))
- ;; multi-dimensional array, will have a header
- t)
- (t
- (give-up-ir1-transform))))))
+ (cond ((not (array-type-p type))
+ nil)
+ (t
+ (let ((dims (array-type-dimensions type)))
+ (cond ((csubtypep type (specifier-type '(simple-array * (*))))
+ ;; no array header
+ (specifier-type 'null))
+ ((and (listp dims) (/= (length dims) 1))
+ ;; multi-dimensional array, will have a header
+ (specifier-type '(eql t)))
+ (t
+ nil)))))))
force-hairy)))
((not (eq vcount :unknown))
(maybe-negate-check value
- (values-type-start ctype vcount)
- (values-type-start atype vcount)
+ (values-type-out ctype vcount)
+ (values-type-out atype vcount)
t))
(t
(values :too-hairy nil))))))))
((= length 1)
(single-value-type atype))
(t
- (make-values-type :required
- (values-type-start atype length)))))
+ (make-values-type
+ :required (values-type-out atype length)))))
(dtype (node-derived-type cast))
- (dtype (make-values-type :required
- (values-type-start dtype length))))
+ (dtype (make-values-type
+ :required (values-type-out dtype length))))
(setf (cast-asserted-type cast) atype)
(setf (node-derived-type cast) dtype)))
;; SIGNED-BYTE arrays, so better make it break now if it ever
;; will:
#+sb-xc-host
+ ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are
+ ;; worried about whether the host's implementation of arrays.
(aver (subtypep (upgraded-array-element-type specializer)
'unsigned-byte))
(coerce seq `(simple-array ,specializer (*)))))))
(unless (gethash (continuation-block cont) *seen-blocks*)
(barf "~S receives ~S, which is in an unknown block." node cont))
(unless (eq (continuation-dest cont) node)
- (barf "DEST for ~S should be ~S." cont node)))))
+ (barf "DEST for ~S should be ~S." cont node))
+ (unless (find-uses cont)
+ (barf "Continuation ~S has a destinatin, but no uses."
+ cont)))))
(values))
;;; This function deals with checking for consistency of the
(check-dest (basic-combination-fun node) node)
(dolist (arg (basic-combination-args node))
(cond
- (arg (check-dest arg node))
- ((not (and (eq (basic-combination-kind node) :local)
- (combination-p node)))
- (barf "flushed arg not in local call: ~S" node))
- (t
- (locally
- ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
- ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
- ;; POSITION. It compiles it correctly, but it issues a type
- ;; mismatch warning because it can't eliminate the
- ;; possibility that control will flow through the
- ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
- (declare (notinline position))
- (let ((fun (ref-leaf (continuation-use
- (basic-combination-fun node))))
- (pos (position arg (basic-combination-args node))))
- (declare (type index pos))
- (when (leaf-refs (elt (lambda-vars fun) pos))
- (barf "flushed arg for referenced var in ~S" node)))))))
+ (arg (check-dest arg node))
+ ((not (and (eq (basic-combination-kind node) :local)
+ (combination-p node)))
+ (barf "flushed arg not in local call: ~S" node))
+ (t
+ (locally
+ ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
+ ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
+ ;; POSITION. It compiles it correctly, but it issues a type
+ ;; mismatch warning because it can't eliminate the
+ ;; possibility that control will flow through the
+ ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
+ (declare (notinline position))
+ (let ((fun (ref-leaf (continuation-use
+ (basic-combination-fun node))))
+ (pos (position arg (basic-combination-args node))))
+ (declare (type index pos))
+ (when (leaf-refs (elt (lambda-vars fun) pos))
+ (barf "flushed arg for referenced var in ~S" node)))))))
(let ((dest (continuation-dest (node-cont node))))
(when (and (return-p dest)
(eq (basic-combination-kind node) :local)
;;; keep garbage from being collected.
(macrolet ((def (counter vto vfrom fto ffrom)
`(progn
+ (declaim (type hash-table ,vto ,vfrom))
(defvar ,vto (make-hash-table :test 'eq))
(defvar ,vfrom (make-hash-table :test 'eql))
- (proclaim '(hash-table ,vto ,vfrom))
+ (declaim (type fixnum ,counter))
(defvar ,counter 0)
- (proclaim '(fixnum ,counter))
(defun ,fto (x)
(or (gethash x ,vto)
(pprint-logical-block (nil nil)
(format t "~:@_IR1 block ~D start c~D"
(block-number block) (cont-num (block-start block)))
+ (when (block-delete-p block)
+ (format t " <deleted>"))
(let ((last (block-last block)))
(pprint-newline :mandatory)
(when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
(minusp (float-sign arg-lo-val)))
(compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo)
- (setq arg-lo '(0e0) arg-lo-val 0e0))
+ (setq arg-lo 0e0 arg-lo-val arg-lo))
(when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
(plusp (float-sign arg-hi-val)))
(compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi)
- (setq arg-hi `(,(ecase *read-default-float-format*
- (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
- #!+long-float
- (long-float (load-time-value (make-unportable-float :long-float-negative-zero)))))
- arg-hi-val (ecase *read-default-float-format*
- (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
- #!+long-float
- (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))))
- (and (or (null domain-low)
- (and arg-lo (>= arg-lo-val domain-low)
- (not (and (zerop domain-low) (floatp domain-low)
- (plusp (float-sign domain-low))
- (zerop arg-lo-val) (floatp arg-lo-val)
- (if (consp arg-lo)
- (plusp (float-sign arg-lo-val))
- (minusp (float-sign arg-lo-val)))))))
- (or (null domain-high)
- (and arg-hi (<= arg-hi-val domain-high)
- (not (and (zerop domain-high) (floatp domain-high)
- (minusp (float-sign domain-high))
- (zerop arg-hi-val) (floatp arg-hi-val)
- (if (consp arg-hi)
- (minusp (float-sign arg-hi-val))
- (plusp (float-sign arg-hi-val))))))))))
+ (setq arg-hi (ecase *read-default-float-format*
+ (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+ #!+long-float
+ (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))
+ arg-hi-val arg-hi))
+ (flet ((fp-neg-zero-p (f) ; Is F -0.0?
+ (and (floatp f) (zerop f) (minusp (float-sign f))))
+ (fp-pos-zero-p (f) ; Is F +0.0?
+ (and (floatp f) (zerop f) (plusp (float-sign f)))))
+ (and (or (null domain-low)
+ (and arg-lo (>= arg-lo-val domain-low)
+ (not (and (fp-pos-zero-p domain-low)
+ (fp-neg-zero-p arg-lo)))))
+ (or (null domain-high)
+ (and arg-hi (<= arg-hi-val domain-high)
+ (not (and (fp-neg-zero-p domain-high)
+ (fp-pos-zero-p arg-hi)))))))))
(eval-when (:compile-toplevel :execute)
(setf *read-default-float-format* 'single-float))
(defknown type-of (t) t (foldable flushable))
;;; These can be affected by type definitions, so they're not FOLDABLE.
-(defknown (upgraded-complex-part-type upgraded-array-element-type)
+(defknown (upgraded-complex-part-type sb!xc:upgraded-array-element-type)
(type-specifier &optional lexenv-designator) type-specifier
(unsafely-flushable))
\f
(foldable flushable call))
(defknown endp (list) boolean (foldable flushable movable))
(defknown list-length (list) (or index null) (foldable unsafely-flushable))
-(defknown nth (index list) t (foldable flushable))
-(defknown nthcdr (index list) t (foldable unsafely-flushable))
-(defknown last (list &optional index) t (foldable flushable))
+(defknown nth (unsigned-byte list) t (foldable flushable))
+(defknown nthcdr (unsigned-byte list) t (foldable unsafely-flushable))
+(defknown last (list &optional unsigned-byte) t (foldable flushable))
(defknown list (&rest t) list (movable flushable unsafe))
(defknown list* (t &rest t) t (movable flushable unsafe))
(defknown make-list (index &key (:initial-element t)) list
(defknown nconc (&rest t) t ())
(defknown nreconc (list t) t ())
-(defknown butlast (list &optional index) list (flushable))
-(defknown nbutlast (list &optional index) list ())
+(defknown butlast (list &optional unsigned-byte) list (flushable))
+(defknown nbutlast (list &optional unsigned-byte) list ())
(defknown ldiff (list t) list (flushable))
(defknown (rplaca rplacd) (cons t) list (unsafe))
(defknown directory (pathname-designator &key)
list ())
\f
-;;;; from the "Errors" chapter:
-
-(defknown error (t &rest t) nil) ; never returns
-(defknown cerror (string t &rest t) null)
+;;;; from the "Conditions" chapter:
+
+(defknown cell-error-name (cell-error) t)
+(defknown error (t &rest t) nil)
+(defknown cerror (format-control t &rest t) null)
+(defknown invalid-method-error (t format-control &rest t) *) ; FIXME: first arg is METHOD
+(defknown method-combination-error (format-control &rest t) *)
+(defknown signal (t &rest t) null)
+(defknown simple-condition-format-control (condition)
+ format-control)
+(defknown simple-condition-format-arguments (condition)
+ list)
(defknown warn (t &rest t) null)
-(defknown break (&optional t &rest t) null)
+(defknown invoke-debugger (condition) nil)
+(defknown break (&optional format-control &rest t) null)
+(defknown make-condition (type-specifier &rest t) condition)
+(defknown compute-restarts (&optional (or condition null)) list)
+(defknown find-restart (restart-designator &optional (or condition null))
+ (or restart null))
+(defknown invoke-restart (restart-designator &rest t) *)
+(defknown invoke-restart-interactively (restart-designator) *)
+(defknown restart-name (restart) symbol)
+(defknown (abort muffle-warning) (&optional (or condition null)) nil)
+(defknown continue (&optional (or condition null)) null)
+(defknown (store-value use-value) (t &optional (or condition null))
+ null)
;;; and analogous SBCL extension:
(defknown bug (t &rest t) nil) ; never returns
(defknown (setf fdocumentation) ((or string null) t symbol)
(or string null)
())
-(defknown %setnth (index list t) t (unsafe))
+(defknown %setnth (unsigned-byte list t) t (unsafe))
(defknown %set-fill-pointer (vector index) index (unsafe))
\f
;;;; miscellaneous internal utilities
(lowtags
(when (cdr lowtags)
(error "can't test multiple lowtags at the same time"))
- (if headers
- `(%test-lowtag-and-headers
- ,value ,target ,not-p ,(car lowtags)
- ,function-p ',(canonicalize-headers headers)
- ,@other-args)
- `(%test-lowtag ,value ,target ,not-p ,(car lowtags)
- ,@other-args)))
+ (when headers
+ (error "can't test non-fixnum lowtags and headers at the same time"))
+ `(%test-lowtag ,value ,target ,not-p ,(car lowtags) ,@other-args))
(headers
`(%test-headers ,value ,target ,not-p ,function-p
',(canonicalize-headers headers)
(deftransform hairy-data-vector-ref ((array index) (array t) * :important t)
"avoid runtime dispatch on array element type"
- (let ((element-ctype (extract-upgraded-element-type array)))
+ (let ((element-ctype (extract-upgraded-element-type array))
+ (declared-element-ctype (extract-declared-element-type array)))
(declare (type ctype element-ctype))
(when (eq *wild-type* element-ctype)
(give-up-ir1-transform
`(multiple-value-bind (array index)
(%data-vector-and-index array index)
(declare (type (simple-array ,element-type-specifier 1) array))
- (data-vector-ref array index)))))
+ ,(let ((bare-form '(data-vector-ref array index)))
+ (if (type= element-ctype declared-element-ctype)
+ bare-form
+ `(the ,(type-specifier declared-element-ctype)
+ ,bare-form)))))))
(deftransform data-vector-ref ((array index)
(simple-array t))
(%array-data-vector array))
index)))))
+(deftransform hairy-data-vector-set ((string index new-value)
+ (simple-string t t))
+ (let ((ctype (continuation-type string)))
+ (if (array-type-p ctype)
+ ;; the other transform will kick in, so that's OK
+ (give-up-ir1-transform)
+ `(typecase string
+ ((simple-array character (*))
+ (data-vector-set string index new-value))
+ ((simple-array nil (*))
+ (data-vector-set string index new-value))))))
+
(deftransform hairy-data-vector-set ((array index new-value)
(array t t)
*
:important t)
"avoid runtime dispatch on array element type"
- (let ((element-ctype (extract-upgraded-element-type array)))
+ (let ((element-ctype (extract-upgraded-element-type array))
+ (declared-element-ctype (extract-declared-element-type array)))
(declare (type ctype element-ctype))
(when (eq *wild-type* element-ctype)
(give-up-ir1-transform
(%data-vector-and-index array index)
(declare (type (simple-array ,element-type-specifier 1) array)
(type ,element-type-specifier new-value))
- (data-vector-set array
- index
- new-value)))))
-
-(deftransform hairy-data-vector-set ((string index new-value)
- (simple-string t t))
- (let ((ctype (continuation-type string)))
- (if (array-type-p ctype)
- ;; the other transform will kick in, so that's OK
- (give-up-ir1-transform)
- `(typecase string
- ((simple-array character (*))
- (data-vector-set string index new-value))
- ((simple-array nil (*))
- (data-vector-set string index new-value))))))
+ ,(if (type= element-ctype declared-element-ctype)
+ '(data-vector-set array index new-value)
+ `(truly-the ,(type-specifier declared-element-ctype)
+ (data-vector-set array index
+ (the ,(type-specifier declared-element-ctype)
+ new-value))))))))
(deftransform data-vector-set ((array index new-value)
(simple-array t t))
(return stype))))))
type))
+(defun sb!xc:upgraded-array-element-type (spec &optional environment)
+ #!+sb-doc
+ "Return the element type that will actually be used to implement an array
+ with the specifier :ELEMENT-TYPE Spec."
+ (declare (ignore environment))
+ (if (unknown-type-p (specifier-type spec))
+ (error "undefined type: ~S" spec)
+ (type-specifier (array-type-specialized-element-type
+ (specifier-type `(array ,spec))))))
+
;;; Return the most specific integer type that can be quickly checked that
;;; includes the given type.
(defun containing-integer-type (subtype)
(inst extru value 31 3 temp))
(inst bci := not-p lowtag temp target)))
-(defun %test-lowtag-and-headers (value target not-p lowtag
- function-p headers &key temp)
- (let ((drop-through (gen-label)))
- (%test-lowtag value (if not-p drop-through target) nil lowtag
- :temp temp)
- (%test-headers value target not-p function-p headers
- :drop-through drop-through :temp temp :temp-loaded t)))
-
(defun %test-headers (value target not-p function-p headers
&key temp (drop-through (gen-label)) temp-loaded)
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
;;; vars.
(defun ir1-optimize-mv-bind (node)
(declare (type mv-combination node))
- (let ((arg (first (basic-combination-args node)))
- (vars (lambda-vars (combination-lambda node))))
- (multiple-value-bind (types nvals)
- (values-types (continuation-derived-type arg))
- (unless (eq nvals :unknown)
- (mapc (lambda (var type)
- (if (basic-var-sets var)
- (propagate-from-sets var type)
- (propagate-to-refs var type)))
- vars
- (adjust-list types
- (length vars)
- (specifier-type 'null)))))
+ (let* ((arg (first (basic-combination-args node)))
+ (vars (lambda-vars (combination-lambda node)))
+ (n-vars (length vars))
+ (types (values-type-in (continuation-derived-type arg)
+ n-vars)))
+ (loop for var in vars
+ and type in types
+ do (if (basic-var-sets var)
+ (propagate-from-sets var type)
+ (propagate-to-refs var type)))
(setf (continuation-reoptimize arg) nil))
(values))
(policy *lexenv* (= inhibit-warnings 3)))
(restart-case
(signal (make-condition 'simple-compiler-note
- :format-string format-string
+ :format-control format-string
:format-arguments format-args))
(muffle-warning ()
(return-from compiler-notify (values))))
(progn
(restart-case
(signal (make-condition 'simple-compiler-note
- :format-string (car rest)
+ :format-control (car rest)
:format-arguments (cdr rest)))
(muffle-warning ()
(return-from maybe-compiler-notify (values))))
(let* ((bind (make-bind))
(lambda (make-lambda :vars vars
- :bind bind
- :%source-name source-name
- :%debug-name debug-name))
+ :bind bind
+ :%source-name source-name
+ :%debug-name debug-name))
(result (or result (make-continuation))))
- (continuation-starts-block result)
-
;; just to check: This function should fail internal assertions if
;; we didn't set up a valid debug name above.
;;
(setf (lambda-home lambda) lambda)
(collect ((svars)
- (new-venv nil cons))
+ (new-venv nil cons))
(dolist (var vars)
;; As far as I can see, LAMBDA-VAR-HOME should never have
(setf (bind-lambda bind) lambda)
(setf (node-lexenv bind) *lexenv*)
- (let ((cont1 (make-continuation))
- (cont2 (make-continuation)))
- (continuation-starts-block cont1)
- (link-node-to-previous-continuation bind cont1)
- (use-continuation bind cont2)
- (ir1-convert-special-bindings cont2 result body
- aux-vars aux-vals (svars)))
-
- (let ((block (continuation-block result)))
- (when block
- (let ((return (make-return :result result :lambda lambda))
- (tail-set (make-tail-set :funs (list lambda)))
- (dummy (make-continuation)))
- (setf (lambda-tail-set lambda) tail-set)
- (setf (lambda-return lambda) return)
- (setf (continuation-dest result) return)
- (flush-continuation-externally-checkable-type result)
- (setf (block-last block) return)
- (link-node-to-previous-continuation return result)
- (use-continuation return dummy))
- (link-blocks block (component-tail *current-component*))))))
+ (let ((block (continuation-starts-block result)))
+ (let ((return (make-return :result result :lambda lambda))
+ (tail-set (make-tail-set :funs (list lambda)))
+ (dummy (make-continuation)))
+ (setf (lambda-tail-set lambda) tail-set)
+ (setf (lambda-return lambda) return)
+ (setf (continuation-dest result) return)
+ (flush-continuation-externally-checkable-type result)
+ (setf (block-last block) return)
+ (link-node-to-previous-continuation return result)
+ (use-continuation return dummy))
+ (link-blocks block (component-tail *current-component*)))
+
+ (with-component-last-block (*current-component*
+ (continuation-block result))
+ (let ((cont1 (make-continuation))
+ (cont2 (make-continuation)))
+ (continuation-starts-block cont1)
+ (link-node-to-previous-continuation bind cont1)
+ (use-continuation bind cont2)
+ (ir1-convert-special-bindings cont2 result body
+ aux-vars aux-vals (svars))))))
(link-blocks (component-head *current-component*) (node-block bind))
(push lambda (component-new-functionals *current-component*))
;;; functional instead.
(defun reference-leaf (start cont leaf)
(declare (type continuation start cont) (type leaf leaf))
+ (when (functional-p leaf)
+ (assure-functional-live-p leaf))
(let* ((type (lexenv-find leaf type-restrictions))
(leaf (or (and (defined-fun-p leaf)
(not (eq (defined-fun-inlinep leaf)
;;; are converting inline expansions for local functions during
;;; optimization.
(defun ir1-convert-local-combination (start cont form functional)
-
- ;; The test here is for "when LET converted", as a translation of
- ;; the old CMU CL comments into code. Unfortunately, the old CMU CL
- ;; comments aren't specific enough to tell whether the correct
- ;; translation is FUNCTIONAL-SOMEWHAT-LETLIKE-P or
- ;; FUNCTIONAL-LETLIKE-P or what. The old CMU CL code assumed that
- ;; any non-null FUNCTIONAL-KIND meant that the function "had been
- ;; LET converted", which might even be right, but seems fragile, so
- ;; we try to be pickier.
- (when (or
- ;; looks LET-converted
- (functional-somewhat-letlike-p functional)
- ;; It's possible for a LET-converted function to end up
- ;; deleted later. In that case, for the purposes of this
- ;; analysis, it is LET-converted: LET-converted functionals
- ;; are too badly trashed to expand them inline, and deleted
- ;; LET-converted functionals are even worse.
- (eql (functional-kind functional) :deleted))
- (throw 'locall-already-let-converted functional))
- ;; Any other non-NIL KIND value is a case we haven't found a
- ;; justification for, and at least some such values (e.g. :EXTERNAL
- ;; and :TOPLEVEL) seem obviously wrong.
- (aver (null (functional-kind functional)))
-
+ (assure-functional-live-p functional)
(ir1-convert-combination start
cont
form
;;; We mark the START as has having no next and remove the last node
;;; from its CONT's uses. We also flush the DEST for all continuations
;;; whose values are received by nodes in the block.
-(defun delete-block (block)
+(defun delete-block (block &optional silent)
(declare (type cblock block))
(aver (block-component block)) ; else block is already deleted!
- (note-block-deletion block)
+ (unless silent
+ (note-block-deletion block))
(setf (block-delete-p block) t)
- (let* ((last (block-last block))
- (cont (node-cont last)))
- (delete-continuation-use last)
- (if (eq (continuation-kind cont) :unused)
- (delete-continuation cont)
- (reoptimize-continuation cont)))
+ (let ((last (block-last block)))
+ (when last
+ (let ((cont (node-cont last)))
+ (delete-continuation-use last)
+ (acond ((eq (continuation-kind cont) :unused)
+ (delete-continuation cont))
+ ((and (null (find-uses cont))
+ (continuation-dest cont))
+ (mark-for-deletion (node-block it)))
+ ((reoptimize-continuation cont))))))
(dolist (b (block-pred block))
(unlink-blocks b block)
(dolist (b (block-succ block))
(unlink-blocks block b))
- (do-nodes (node cont block)
+ (do-nodes-carefully (node cont block)
(typecase node
(ref (delete-ref node))
(cif
;; careful that this LET has not already been partially deleted.
(basic-combination
(when (and (eq (basic-combination-kind node) :local)
- ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
- (continuation-use (basic-combination-fun node)))
- (let ((fun (combination-lambda node)))
- ;; If our REF was the second-to-last ref, and has been
- ;; deleted, then FUN may be a LET for some other
- ;; combination.
- (when (and (functional-letlike-p fun)
- (eq (let-combination fun) node))
- (delete-lambda fun))))
+ ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
+ (continuation-use (basic-combination-fun node)))
+ (let ((fun (combination-lambda node)))
+ ;; If our REF was the second-to-last ref, and has been
+ ;; deleted, then FUN may be a LET for some other
+ ;; combination.
+ (when (and (functional-letlike-p fun)
+ (eq (let-combination fun) node))
+ (delete-lambda fun))))
(flush-dest (basic-combination-fun node))
(dolist (arg (basic-combination-args node))
- (when arg (flush-dest arg))))
+ (when arg (flush-dest arg))))
(bind
(let ((lambda (bind-lambda node)))
- (unless (eq (functional-kind lambda) :deleted)
- (delete-lambda lambda))))
+ (unless (eq (functional-kind lambda) :deleted)
+ (delete-lambda lambda))))
(exit
(let ((value (exit-value node))
- (entry (exit-entry node)))
- (when value
- (flush-dest value))
- (when entry
- (setf (entry-exits entry)
- (delete node (entry-exits entry))))))
+ (entry (exit-entry node)))
+ (when value
+ (flush-dest value))
+ (when entry
+ (setf (entry-exits entry)
+ (delete node (entry-exits entry))))))
(creturn
(flush-dest (return-result node))
(delete-return node))
(cset
(flush-dest (set-value node))
(let ((var (set-var node)))
- (setf (basic-var-sets var)
- (delete node (basic-var-sets var)))))
+ (setf (basic-var-sets var)
+ (delete node (basic-var-sets var)))))
(cast
(flush-dest (cast-value node))))
*inline-expansion-limit*))
nil)
(t t))))
+
+;;; Make sure that FUNCTIONAL is not let-converted or deleted.
+(defun assure-functional-live-p (functional)
+ (declare (type functional functional))
+ (when (and (or
+ ;; looks LET-converted
+ (functional-somewhat-letlike-p functional)
+ ;; It's possible for a LET-converted function to end up
+ ;; deleted later. In that case, for the purposes of this
+ ;; analysis, it is LET-converted: LET-converted functionals
+ ;; are too badly trashed to expand them inline, and deleted
+ ;; LET-converted functionals are even worse.
+ (eql (functional-kind functional) :deleted)))
+ (throw 'locall-already-let-converted functional)))
\f
;;;; careful call
(predicate-type nil :type (or ctype null)))
(defprinter (fun-info)
+ (attributes :test (not (zerop attributes))
+ :prin1 (decode-ir1-attributes attributes))
(transforms :test transforms)
(derive-type :test derive-type)
(optimizer :test optimizer)
(>= speed compilation-speed)))
(not (eq (functional-kind (node-home-lambda call)) :external))
(inline-expansion-ok call))
- (multiple-value-bind (losing-local-functional converted-lambda)
- (catch 'locall-already-let-converted
- (with-ir1-environment-from-node call
- (let ((*lexenv* (functional-lexenv original-functional)))
- (values nil
- (ir1-convert-lambda
- (functional-inline-expansion original-functional)
- :debug-name (debug-namify
- "local inline ~A"
- (leaf-debug-name
- original-functional)))))))
- (cond (losing-local-functional
- (let ((*compiler-error-context* call))
- (compiler-notify "couldn't inline expand because expansion ~
+ (let* ((end (component-last-block (node-component call)))
+ (pred (block-prev end)))
+ (multiple-value-bind (losing-local-functional converted-lambda)
+ (catch 'locall-already-let-converted
+ (with-ir1-environment-from-node call
+ (let ((*lexenv* (functional-lexenv original-functional)))
+ (values nil
+ (ir1-convert-lambda
+ (functional-inline-expansion original-functional)
+ :debug-name (debug-namify
+ "local inline ~A"
+ (leaf-debug-name
+ original-functional)))))))
+ (cond (losing-local-functional
+ (let ((*compiler-error-context* call))
+ (compiler-notify "couldn't inline expand because expansion ~
calls this LET-converted local function:~
~% ~S"
- (leaf-debug-name losing-local-functional)))
- original-functional)
- (t
- (change-ref-leaf ref converted-lambda)
- converted-lambda)))
+ (leaf-debug-name losing-local-functional)))
+ (loop for block = (block-next pred) then (block-next block)
+ until (eq block end)
+ do (setf (block-delete-p block) t))
+ (loop for block = (block-next pred) then (block-next block)
+ until (eq block end)
+ do (delete-block block t))
+ original-functional)
+ (t
+ (change-ref-leaf ref converted-lambda)
+ converted-lambda))))
original-functional))
;;; Dispatch to the appropriate function to attempt to convert a call.
(def!macro !def-boolean-attribute (name &rest attribute-names)
(let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
- (test-name (symbolicate name "-ATTRIBUTEP")))
+ (test-name (symbolicate name "-ATTRIBUTEP"))
+ (decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES")))
(collect ((alist))
(do ((mask 1 (ash mask 1))
(names attribute-names (cdr names)))
;; building the xc and when building the target compiler.
(!def-boolean-attribute-setter ,test-name
,translations-name
- ,@attribute-names)))))
+ ,@attribute-names)
+ (defun ,decoder-name (attributes)
+ (loop for (name . mask) in ,translations-name
+ when (logtest mask attributes)
+ collect name))))))
;; It seems to be difficult to express in DEF!MACRO machinery what
;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just
(when (eq ,n-next ,n-start)
(return nil))))))
+(defmacro do-nodes-carefully ((node-var cont-var block) &body body)
+ (with-unique-names (n-block n-last)
+ `(loop with ,n-block = ,block
+ with ,n-last = (block-last ,n-block)
+ for ,cont-var = (block-start ,n-block) then (node-cont ,node-var)
+ for ,node-var = (and ,cont-var (continuation-next ,cont-var))
+ while ,node-var
+ do (progn ,@body)
+ until (eq ,node-var ,n-last))))
+
;;; Bind the IR1 context variables to the values associated with NODE,
;;; so that new, extra IR1 conversion related to NODE can be done
;;; after the original conversion pass has finished.
(incf *aborted-compilation-unit-count*))
(summarize-compilation-unit (not succeeded-p)))))))))
+;;; Is FUN-NAME something that no conforming program can rely on
+;;; defining as a function?
+(defun fun-name-reserved-by-ansi-p (fun-name)
+ (eq (symbol-package (fun-name-block-name fun-name))
+ *cl-package*))
+
;;; This is to be called at the end of a compilation unit. It signals
;;; any residual warnings about unknown stuff, then prints the total
;;; error counts. ABORT-P should be true when the compilation unit was
(undefined-warning-count (undefined-warning-count undef)))
(dolist (*compiler-error-context* warnings)
(if #-sb-xc-host (and (eq kind :function)
- (symbolp name) ; FIXME: (SETF CL:fo)
- (eq (symbol-package name) *cl-package*)
+ (fun-name-reserved-by-ansi-p name)
*flame-on-necessarily-undefined-function*)
#+sb-xc-host nil
- (compiler-warn "undefined ~(~A~): ~S" kind name)
+ (case name
+ ((declare)
+ (compiler-warn
+ "~@<There is no function named ~S. References to ~S in ~
+ some contexts (like starts of blocks) have special ~
+ meaning, but here it would have to be a function, ~
+ and that shouldn't be right.~:@>"
+ name name))
+ (t
+ (compiler-warn
+ "~@<The ~(~A~) ~S is undefined, and its name is ~
+ reserved by ANSI CL so that even if it it were ~
+ defined later, the code doing so would not be ~
+ portable.~:@>"
+ kind name)))
(compiler-style-warn "undefined ~(~A~): ~S" kind name)))
(let ((warn-count (length warnings)))
(when (and warnings (> undefined-warning-count warn-count))
,(eval offset))))
(:results (value :scs ,scs))
(:result-types ,el-type)
- (:generator 5
+ (:generator 4
(inst ,(ecase size
(:byte (if signed 'lb 'lbu))
(:short (if signed 'lh 'lhu)))
,el-type)
(:results (result :scs ,scs))
(:result-types ,el-type)
- (:generator 5
+ (:generator 4
(inst ,(ecase size (:byte 'sb) (:short 'sh))
value object
- (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag))
+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
(move result value))))))
*current-catch-block*
*current-unwind-protect-block*
+ *binding-stack-start*
+ *control-stack-start*
+ *control-stack-end*
+
;; Interrupt Handling
*free-interrupt-context-index*
sb!unix::*interrupts-enabled*
(unless skip-nop
(inst nop))))
-(defun %test-lowtag-and-headers (value target not-p lowtag
- function-p headers &key temp)
- (let ((drop-through (gen-label)))
- (%test-lowtag value (if not-p drop-through target) nil lowtag
- :skip-nop t :temp temp)
- (%test-headers value target not-p function-p headers
- :drop-through drop-through :temp temp)))
-
(defun %test-headers (value target not-p function-p headers
&key (drop-through (gen-label)) temp)
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
-;;;
-;;; Written by Rob MacLachlan
-;;; Converted for the MIPS R2000 by Christopher Hoover.
-;;; And then to the SPARC by William Lott.
-;;;
-(in-package "SB!VM")
+;;;; the PPC VM definition of character operations
+;;;; 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!VM")
\f
;;;; Moves and coercions:
;;; Move a tagged char to an untagged representation.
-;;;
(define-vop (move-to-base-char)
(:args (x :scs (any-reg descriptor-reg)))
(:results (y :scs (base-char-reg)))
(:note "character untagging")
(:generator 1
(inst srwi y x sb!vm:n-widetag-bits)))
-;;;
+
(define-move-vop move-to-base-char :move
(any-reg descriptor-reg) (base-char-reg))
;;; Move an untagged char to a tagged representation.
-;;;
(define-vop (move-from-base-char)
(:args (x :scs (base-char-reg)))
(:results (y :scs (any-reg descriptor-reg)))
(:generator 1
(inst slwi y x sb!vm:n-widetag-bits)
(inst ori y y sb!vm:base-char-widetag)))
-;;;
+
(define-move-vop move-from-base-char :move
(base-char-reg) (any-reg descriptor-reg))
;;; Move untagged base-char values.
-;;;
(define-vop (base-char-move)
(:args (x :target y
:scs (base-char-reg)
(:affected)
(:generator 0
(move y x)))
-;;;
+
(define-move-vop base-char-move :move
(base-char-reg) (base-char-reg))
-
;;; Move untagged base-char arguments/return-values.
-;;;
(define-vop (move-base-char-arg)
(:args (x :target y
:scs (base-char-reg))
(move y x))
(base-char-stack
(storew x fp (tn-offset y))))))
-;;;
+
(define-move-vop move-base-char-arg :move-arg
(any-reg base-char-reg) (base-char-reg))
;;; Use standard MOVE-ARG + coercion to move an untagged base-char
;;; to a descriptor passing location.
-;;;
(define-move-vop move-arg :move-arg
(base-char-reg) (any-reg descriptor-reg))
\f
;;; Comparison of base-chars.
-;;;
(define-vop (base-char-compare)
(:args (x :scs (base-char-reg))
(y :scs (base-char-reg)))
(:translate char>)
(:variant :gt :le))
+(define-vop (base-char-compare/c)
+ (:args (x :scs (base-char-reg)))
+ (:arg-types base-char (:constant base-char))
+ (:conditional)
+ (:info target not-p y)
+ (:policy :fast-safe)
+ (:note "inline comparison")
+ (:variant-vars condition not-condition)
+ (:generator 2
+ (inst cmplwi x (sb!xc:char-code y))
+ (inst b? (if not-p not-condition condition) target)))
+
+(define-vop (fast-char=/base-char/c base-char-compare/c)
+ (:translate char=)
+ (:variant :eq :ne))
+
+(define-vop (fast-char</base-char/c base-char-compare/c)
+ (:translate char<)
+ (:variant :lt :ge))
+
+(define-vop (fast-char>/base-char/c base-char-compare/c)
+ (:translate char>)
+ (:variant :gt :le))
+
-;;;
-;;; Written by William Lott
-;;;
+;;;; the instruction set definition for the PPC
+
+;;;; 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!VM")
;(def-assembler-params
; :scheduler-p nil ; t when we trust the scheduler not to "fill delay slots"
; :max-locations 70)
-
-
\f
;;;; Constants, types, conversion functions, some disassembler stuff.
(define-instruction-macro rotlw. (ra rs rb)
`(inst rlwnm. ,ra ,rs ,rb 0 31))
+ (define-instruction-macro rotlwi (ra rs n)
+ `(inst rlwinm ,ra ,rs ,n 0 31))
+
+ (define-instruction-macro rotrwi (ra rs n)
+ `(inst rlwinm ,ra ,rs (- 32 ,n) 0 31))
+
(define-instruction-macro slwi (ra rs n)
`(inst rlwinm ,ra ,rs ,n 0 (- 31 ,n)))
(inst cmpwi temp lowtag)
(inst b? (if not-p :ne :eq) target)))
-(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers
- &key temp)
- (let ((drop-through (gen-label)))
- (%test-lowtag value (if not-p drop-through target) not-p lowtag
- :temp temp)
- (%test-headers value target not-p function-p headers
- :temp temp :drop-through drop-through)))
-
(defun %test-headers (value target not-p function-p headers
&key temp (drop-through (gen-label)))
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(t
decl-spec)))))
+(defvar *queued-proclaims*) ; initialized in !COLD-INIT-FORMS
+
(!begin-collecting-cold-init-forms)
-(!cold-init-forms (defvar *queued-proclaims* nil))
+(!cold-init-forms (setf *queued-proclaims* nil))
(!defun-from-collected-cold-init-forms !early-proclaim-cold-init)
(defun sb!xc:proclaim (raw-form)
(define-vop (fast-char>/base-char base-char-compare)
(:translate char>)
(:variant :gtu :leu))
+
+(define-vop (base-char-compare/c)
+ (:args (x :scs (base-char-reg)))
+ (:arg-types base-char (:constant base-char))
+ (:conditional)
+ (:info target not-p y)
+ (:policy :fast-safe)
+ (:note "inline constant comparison")
+ (:variant-vars condition not-condition)
+ (:generator 2
+ (inst cmp x (sb!xc:char-code y))
+ (inst b (if not-p not-condition condition) target)
+ (inst nop)))
+
+(define-vop (fast-char=/base-char/c base-char-compare/c)
+ (:translate char=)
+ (:variant :eq :ne))
+
+(define-vop (fast-char</base-char/c base-char-compare/c)
+ (:translate char<)
+ (:variant :ltu :geu))
+
+(define-vop (fast-char>/base-char/c base-char-compare/c)
+ (:translate char>)
+ (:variant :gtu :leu))
(unless skip-nop
(inst nop))))
-(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers
- &key temp)
- (let ((drop-through (gen-label)))
- (%test-lowtag value (if not-p drop-through target) not-p lowtag
- :temp temp :skip-nop t)
- (%test-headers value target not-p function-p headers
- :temp temp :drop-through drop-through)))
-
(defun %test-headers (value target not-p function-p headers
&key temp (drop-through (gen-label)))
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(deftransform > ((x y) (float float) *)
(ir1-transform-< y x x y '<))
+
+(defun ir1-transform-char< (x y first second inverse)
+ (cond
+ ((same-leaf-ref-p x y) nil)
+ ;; If we had interval representation of character types, as we
+ ;; might eventually have to to support 2^21 characters, then here
+ ;; we could do some compile-time computation as in IR1-TRANSFORM-<
+ ;; above. -- CSR, 2003-07-01
+ ((and (constant-continuation-p first)
+ (not (constant-continuation-p second)))
+ `(,inverse y x))
+ (t (give-up-ir1-transform))))
+
+(deftransform char< ((x y) (character character) *)
+ (ir1-transform-char< x y x y 'char>))
+
+(deftransform char> ((x y) (character character) *)
+ (ir1-transform-char< y x x y 'char<))
\f
;;;; converting N-arg comparisons
;;;;
;;; trying to optimize it.
(defun source-transform-union-typep (object type)
(let* ((types (union-type-types type))
- (ltype (specifier-type 'list))
- (mtype (find-if #'member-type-p types)))
- (if (and mtype (csubtypep ltype type))
- (let ((members (member-type-members mtype)))
- (once-only ((n-obj object))
- `(or (listp ,n-obj)
- (typep ,n-obj
- '(or ,@(mapcar #'type-specifier
- (remove (specifier-type 'cons)
- (remove mtype types)))
- (member ,@(remove nil members)))))))
+ (type-list (specifier-type 'list))
+ (type-cons (specifier-type 'cons))
+ (mtype (find-if #'member-type-p types))
+ (members (when mtype (member-type-members mtype))))
+ (if (and mtype
+ (memq nil members)
+ (memq type-cons types))
+ (once-only ((n-obj object))
+ `(or (listp ,n-obj)
+ (typep ,n-obj
+ '(or ,@(mapcar #'type-specifier
+ (remove type-cons
+ (remove mtype types)))
+ (member ,@(remove nil members))))))
(once-only ((n-obj object))
`(or ,@(mapcar (lambda (x)
`(typep ,n-obj ',(type-specifier x)))
(define-vop (fast-char>/base-char base-char-compare)
(:translate char>)
(:variant :a :na))
+
+(define-vop (base-char-compare/c)
+ (:args (x :scs (base-char-reg base-char-stack)))
+ (:arg-types base-char (:constant base-char))
+ (:conditional)
+ (:info target not-p y)
+ (:policy :fast-safe)
+ (:note "inline constant comparison")
+ (:variant-vars condition not-condition)
+ (:generator 2
+ (inst cmp x (sb!xc:char-code y))
+ (inst jmp (if not-p not-condition condition) target)))
+
+(define-vop (fast-char=/base-char/c base-char-compare/c)
+ (:translate char=)
+ (:variant :e :ne))
+
+(define-vop (fast-char</base-char/c base-char-compare/c)
+ (:translate char<)
+ (:variant :b :nb))
+
+(define-vop (fast-char>/base-char/c base-char-compare/c)
+ (:translate char>)
+ (:variant :a :na))
(descriptor-reg
(inst fstp fr0)
(inst fldd (ea-for-df-desc y)))))
+ ((and (sc-is x double-reg) (zerop (tn-offset x))
+ (sc-is y double-reg) (zerop (tn-offset x)))
+ ;; copy x to fr1
+ (inst fst fr1))
;; y in fr0; x not in fr1
((and (sc-is y double-reg) (zerop (tn-offset y)))
(inst fxch fr1)
(inst cmp al-tn lowtag)
(inst jmp (if not-p :ne :e) target))
-(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers)
- (let ((drop-through (gen-label)))
- (%test-lowtag value (if not-p drop-through target) nil lowtag)
- (%test-headers value target not-p function-p headers drop-through t)))
-
-
(defun %test-headers (value target not-p function-p headers
&optional (drop-through (gen-label)) al-loaded)
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(setq *boot-state* 'braid)
(defmethod no-applicable-method (generic-function &rest args)
- (error "~@<There is no matching method for the generic function ~2I~_~S~
+ (error "~@<There is no applicable method for the generic function ~2I~_~S~
~I~_when called with arguments ~2I~_~S.~:>"
generic-function
args))
(let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
(if (array-in-bounds-p ps i)
(aref ps i)
- (intern (format nil ".D~D." i) *the-pcl-package*)))))
+ (intern (format nil ".D~D." i) *pcl-package*)))))
;; Loop over supplied initargs and values and record which
;; instance and class slots they initialize.
(loop for (key value) on initargs by #'cddr
`(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
primary)))))
(cond ((null primary)
- ;; FIXME(?): NO-APPLICABLE-METHOD seems more appropriate
- ;; here, but
- ;; (1) discussion with CSR on #lisp reminded me that it's
- ;; a vexed question whether we can validly call
- ;; N-A-M when an :AROUND method exists (and the
- ;; definition of NO-NEXT-METHOD seems to discourage
- ;; us from calling NO-NEXT-METHOD directly in that
- ;; case, since it's supposed to be called from a
- ;; CALL-NEXT-METHOD form), and
- ;; (2) a call to N-A-M would require &REST FUN-ARGS, and
- ;; we don't seem to have FUN-ARGS here.
- ;; I think ideally failures in short method combination
- ;; would end up either in NO-APPLICABLE-METHOD or
- ;; NO-NEXT-METHOD, and I expect that's what ANSI
- ;; generally intended, but it's not clear to me whether
- ;; the details of what they actually specified let us
- ;; make that happen. So for now I've just tried to
- ;; clarify the error message text but left the general
- ;; logic alone (and raised the question on sbcl-devel).
- ;; -- WHN 2003-06-16
- `(error "no ~S methods for ~S on these arguments"
- ',type
- ',generic-function))
+ ;; As of sbcl-0.8.0.80 we don't seem to need to need
+ ;; to do anything messy like
+ ;; `(APPLY (FUNCTION (IF AROUND
+ ;; 'NO-PRIMARY-METHOD
+ ;; 'NO-APPLICABLE-METHOD)
+ ;; ',GENERIC-FUNCTION
+ ;; .ARGS.)
+ ;; here because (for reasons I don't understand at the
+ ;; moment -- WHN) control will never reach here if there
+ ;; are no applicable methods, but instead end up
+ ;; in NO-APPLICABLE-METHODS first.
+ ;;
+ ;; FIXME: The way that we arrange for .ARGS. to be bound
+ ;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION
+ ;; recognizing any form whose operator is %NO-PRIMARY-METHOD
+ ;; as magical, and carefully surrounding it with a
+ ;; LAMBDA form which binds .ARGS. But...
+ ;; 1. That seems fragile, because the magicalness of
+ ;; %NO-PRIMARY-METHOD forms is scattered around
+ ;; the system. So it could easily be broken by
+ ;; locally-plausible maintenance changes like,
+ ;; e.g., using the APPLY expression above.
+ ;; 2. That seems buggy w.r.t. to MOPpish tricks in
+ ;; user code, e.g.
+ ;; (DEFMETHOD COMPUTE-EFFECTIVE-METHOD :AROUND (...)
+ ;; `(PROGN ,(CALL-NEXT-METHOD) (INCF *MY-CTR*)))
+ `(%no-primary-method ',generic-function .args.))
((null around) main-method)
(t
`(call-method ,(car around)
(if (null methods)
(format stream "~&It has no methods.~%")
(let ((gf-name (generic-function-name fun)))
- (format stream "Its methods are:")
+ (format stream "~&Its methods are:")
(dolist (method methods)
(format stream "~2% (~A ~{~S ~}~:S) =>"
gf-name
include Config
-C_SRCS =alloc.c backtrace.c breakpoint.c coreparse.c \
+C_SRCS = alloc.c backtrace.c breakpoint.c coreparse.c \
dynbind.c gc-common.c globals.c interr.c interrupt.c \
monitor.c parse.c print.c purify.c \
regnames.c run-program.c runtime.c save.c search.c \
thread.c time.c util.c validate.c vars.c wrap.c
-SRCS= $(C_SRCS) ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} ${GC_SRC}
+SRCS = $(C_SRCS) ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} ${GC_SRC}
OBJS = $(patsubst %.c,%.o,$(patsubst %.S,%.o,$(patsubst %.s,%.o,$(SRCS))))
if ((((unsigned long)pc) & 3) != 0 ||
((pc < READ_ONLY_SPACE_START ||
pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) &&
- ((lispobj *)pc < current_dynamic_space &&
+ ((lispobj *)pc < current_dynamic_space ||
(lispobj *)pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE)))
return 0;
(assert (eq (array-element-type a) 'nil)))
(assert (eq (upgraded-array-element-type 'nil) 'nil))
+
+(multiple-value-bind (fun warn fail)
+ (compile nil '(lambda () (aref (make-array 0) 0)))
+ #+nil (assert fail) ; doesn't work, (maybe because ASSERTED-TYPE is NIL?)
+ (assert (raises-error? (funcall fun) type-error)))
+
+(multiple-value-bind (fun warn fail)
+ (compile nil '(lambda () (aref (make-array 1) 1)))
+ (assert fail)
+ (assert (raises-error? (funcall fun) type-error)))
+
+(multiple-value-bind (fun warn fail)
+ (compile nil '(lambda () (make-array 5 :element-type 'undefined-type)))
+ (assert warn))
(list x (call-next-method) (call-next-method x))))
(assert (equal (cnm-assignment 1) '(3 1 3)))
\f
+;;; Bug reported by Istvan Marko 2003-07-09
+(let ((class-name (gentemp)))
+ (loop for i from 1 to 9
+ for slot-name = (intern (format nil "X~D" i))
+ for initarg-name = (intern (format nil "X~D" i) :keyword)
+ collect `(,slot-name :initarg ,initarg-name) into slot-descs
+ append `(,initarg-name (list 0)) into default-initargs
+ finally (eval `(defclass ,class-name ()
+ (,@slot-descs)
+ (:default-initargs ,@default-initargs))))
+ (let ((f (compile nil `(lambda () (make-instance ',class-name)))))
+ (assert (typep (funcall f) class-name))))
+
;;;; success
(sb-ext:quit :unix-status 104)
;;; bug 31 turned out to be a manifestation of non-ANSI array type
;;; handling, fixed by CSR in sbcl-0.7.3.8.
(defun array-element-type-handling (x)
+ (declare (optimize safety))
(declare (type (vector cons) x))
(when (consp (aref x 0))
(aref x 0)))
-(assert (eq (array-element-type-handling
- (make-array 3 :element-type t :initial-element 0))
- nil))
+(assert (raises-error?
+ (array-element-type-handling
+ (make-array 3 :element-type t :initial-element 0))
+ type-error))
;;; bug 220: type check inserted after all arguments in MV-CALL caused
;;; failure of stack analysis
(frob)))))))
(delete-package :bug255)
+;;; bug 148
+(defpackage :bug148 (:use :cl))
+(in-package :bug148)
+
+(defvar *thing*)
+(defvar *zoom*)
+(defstruct foo bar bletch)
+(defun %zeep ()
+ (labels ((kidify1 (kid)
+ )
+ (kid-frob (kid)
+ (if *thing*
+ (setf sweptm
+ (m+ (frobnicate kid)
+ sweptm))
+ (kidify1 kid))))
+ (declare (inline kid-frob))
+ (map nil
+ #'kid-frob
+ (the simple-vector (foo-bar perd)))))
+
+(declaim (optimize (safety 3) (speed 2) (space 1)))
+(defvar *foo*)
+(defvar *bar*)
+(defun u-b-sra (x r ad0 &optional ad1 &rest ad-list)
+ (labels ((c.frob (c0)
+ (let ()
+ (when *foo*
+ (vector-push-extend c0 *bar*))))
+ (ad.frob (ad)
+ (if *foo*
+ (map nil #'ad.frob (the (vector t) *bar*))
+ (dolist (b *bar*)
+ (c.frob b)))))
+ (declare (inline c.frob ad.frob)) ; 'til DYNAMIC-EXTENT
+ (ad.frob ad0)))
+
+(defun bug148-3 (ad0)
+ (declare (special *foo* *bar*))
+ (declare (optimize (safety 3) (speed 2) (space 1)))
+ (labels ((c.frob ())
+ (ad.frob (ad)
+ (if *foo*
+ (mapc #'ad.frob *bar*)
+ (dolist (b *bar*)
+ (c.frob)))))
+ (declare (inline c.frob ad.frob))
+ (ad.frob ad0)))
+
+(defun bug148-4 (ad0)
+ (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
+ (labels ((c.frob (x)
+ (* 7 x))
+ (ad.frob (ad)
+ (loop for b in ad
+ collect (c.frob b))))
+ (declare (inline c.frob ad.frob))
+ (list (the list ad0)
+ (funcall (if (listp ad0) #'ad.frob #'print) ad0)
+ (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0)))))
+
+(assert (equal (eval '(bug148-4 '(1 2 3)))
+ '((1 2 3) (7 14 21) (21 14 7))))
+
+(delete-package :bug148)
+
+;;; bug 258
+(defpackage :bug258 (:use :cl))
+(in-package :bug258)
+
+(defun u-b-sra (ad0)
+ (declare (special *foo* *bar*))
+ (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
+ (labels ((c.frob (x)
+ (1- x))
+ (ad.frob (ad)
+ (mapcar #'c.frob ad)))
+ (declare (inline c.frob ad.frob))
+ (list (the list ad0)
+ (funcall (if (listp ad0) #'ad.frob #'print) ad0)
+ (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0)))))
+
+(assert (equal (u-b-sra '(4 9 7))
+ '((4 9 7) (3 8 6) (6 8 3))))
+
+(delete-package :bug258)
+
\f
(sb-ext:quit :unix-status 104)
(list (bar x) (bar x) (bar x))))
(assert (raises-error? (bug249 1.0) type-error))
+
+;;; bug reported by ohler on #lisp 2003-07-10
+(defun bug-ohler-2003-07-10 (a b)
+ (declare (optimize (speed 0) (safety 3) (space 0)
+ (debug 1) (compilation-speed 0)))
+ (adjoin a b))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
(assert (equal y #*00))
(funcall f y 1)
(assert (equal y #*10))))
+
+(handler-bind ((sb-ext:compiler-note #'error))
+ (compile nil '(lambda (x)
+ (declare (type (simple-array (simple-string 3) (5)) x))
+ (aref (aref x 0) 0))))
+
+;; compiler failure
+(let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0)))))))
+ (assert (funcall f 1d0)))
+
+(compile nil '(lambda (x)
+ (declare (double-float x))
+ (let ((y (* x pi)))
+ (atan y y))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(cl:in-package :cl-user)
+
+;;; Bug from CLOCC.
+(defpackage :p1
+ (:use :cl)
+ (:export #:code #:code-msg #:%code-msg))
+(in-package :p1)
+(define-condition code ()
+ ((msg :reader code-msg :reader %code-msg :initarg :msg)))
+
+(defpackage :p2
+ (:use :cl :p1))
+(in-package :p2)
+(define-condition code1 (code)
+ ((msg :accessor code-msg :initarg :msg)))
+
+(let ((code (make-condition 'code :msg 1)))
+ (assert (typep code 'code))
+ (assert (eql (code-msg code) 1))
+ (assert (eql (%code-msg code) 1)))
+(let ((code (make-condition 'code1 :msg 1)))
+ (assert (typep code 'code))
+ (assert (eql (code-msg code) 1))
+ (assert (eql (%code-msg code) 1))
+ (setf (code-msg code) 2)
+ (assert (eql (code-msg code) 2))
+ (assert (eql (%code-msg code) 1)))
+
+;;; success
+(sb-ext:quit :unix-status 104)
(foo () :test (lambda (c) (declare (ignore c)) visible)
'in2))
(foo () 'ext)))))))
+
+;;; First argument of CERROR is a format control
+(assert
+ (eq (block nil
+ (handler-bind
+ ((type-error (lambda (c) (return :failed)))
+ (simple-error (lambda (c)
+ (return (if (find-restart 'continue)
+ :passed
+ :failed)))))
+ (cerror (formatter "Continue from ~A") "bug ~A" :bug)))
+ :passed))
(c #\# :type (integer 5 6)))
(let ((s (make-boa-saux)))
(declare (notinline identity))
- #+nil ; bug 235a
(locally (declare (optimize (safety 3))
(inline boa-saux-a))
(assert (raises-error? (identity (boa-saux-a s)) type-error)))
(assert (eql (boa-saux-b s) 3))
(assert (eql (boa-saux-c s) 5)))
+(let ((s (make-boa-saux)))
+ (declare (notinline identity))
+ (locally (declare (optimize (safety 3))
+ (notinline boa-saux-a))
+ (assert (raises-error? (identity (boa-saux-a s)) type-error)))
+ (setf (boa-saux-a s) 1)
+ (setf (boa-saux-c s) 5)
+ (assert (eql (boa-saux-a s) 1))
+ (assert (eql (boa-saux-b s) 3))
+ (assert (eql (boa-saux-c s) 5)))
+
;;; basic inheritance
(defstruct (astronaut (:include person)
(:conc-name astro-))
(assert (vector-struct-p (make-vector-struct)))
(assert (not (vector-struct-p nil)))
(assert (not (vector-struct-p #())))
+\f
+;;; bug 3d: type safety with redefined type constraints on slots
+(macrolet
+ ((test (type)
+ (let* ((base-name (intern (format nil "bug3d-~A" type)))
+ (up-name (intern (format nil "~A-up" base-name)))
+ (accessor (intern (format nil "~A-X" base-name)))
+ (up-accessor (intern (format nil "~A-X" up-name)))
+ (type-options (when type `((:type ,type)))))
+ `(progn
+ (defstruct (,base-name ,@type-options)
+ x y)
+ (defstruct (,up-name (:include ,base-name
+ (x "x" :type simple-string)
+ (y "y" :type simple-string))
+ ,@type-options))
+ (let ((ob (,(intern (format nil "MAKE-~A" up-name)))))
+ (setf (,accessor ob) 0)
+ (loop for decl in '(inline notinline)
+ for fun = `(lambda (s)
+ (declare (optimize (safety 3))
+ (,decl ,',up-accessor))
+ (,',up-accessor s))
+ do (assert (raises-error? (funcall (compile nil fun) ob)
+ type-error))))))))
+ (test nil)
+ (test list)
+ (test vector))
+
+(let* ((name (gensym))
+ (form `(defstruct ,name
+ (x nil :type (or null (function (integer)
+ (values number &optional foo)))))))
+ (eval (copy-tree form))
+ (eval (copy-tree form)))
;;; success
(format t "~&/returning success~%")
;;; Bug reported by Paul Dietz: CONSTANTP on a self-evaluating object
;;; must return T
-
(assert (constantp (find-class 'symbol)))
(assert (constantp #p""))
,var))
'(1 2))))
-\f
;;; success
(sb-ext:quit :unix-status 104)
(list 4 1 3 3))
#'<))
'(2 4)))
+
+;;; Bug reported by Adam Warner: valid list index designator is not
+;;; necessary a fixnum
+(let ((s (read-from-string "(a . #1=(b c . #1#))")))
+ (assert (eq (nth (* 1440 most-positive-fixnum) s) 'c))
+ (setf (nth (* 1440 most-positive-fixnum) s) 14)
+ (assert (eq (nth (* 1440 most-positive-fixnum) s) 14)))
+
+(let ((s (copy-list '(1 2 3))))
+ (assert (eq s (last s (* 1440 most-positive-fixnum))))
+ (assert (null (butlast s (* 1440 most-positive-fixnum))))
+ (assert (null (nbutlast s (* 1440 most-positive-fixnum)))))
;;; way to make an automated test:
;;; (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
+;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
+;;; PPRINT-LOGICAL-BLOCK may be complex strings
+(let ((list '(1 2 3))
+ (prefix (make-array 2
+ :element-type 'character
+ :displaced-to ";x"
+ :fill-pointer 1))
+ (suffix (make-array 2
+ :element-type 'character
+ :displaced-to ">xy"
+ :displaced-index-offset 1
+ :fill-pointer 1)))
+ (assert (equal (with-output-to-string (s)
+ (pprint-logical-block (s list
+ :per-line-prefix prefix
+ :suffix suffix)
+ (format s "~{~W~^~:@_~}" list)))
+ (format nil ";1~%~
+ ;2~%~
+ ;3x"))))
+
+
;;; success
(quit :unix-status 104)
(when (or warnings-p failure-p)
(error "~@<failed compilation:~2I ~_LAMBDA-EXPR=~S ~_WARNINGS-P=~S ~_FAILURE-P=~S~:@>"
lambda-expr warnings-p failure-p))
- (format t "~&~S ~S ~S ~S ~S~%"
+ (format t "~&~S ~S~%~S~%~S ~S~%"
base-seq snippet seq-type declaredness optimization)
(format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
(typep seq 'simple-array))
(setf (fill-pointer string) 5)))
(declare (ignorable #'reset))
,@body))))
-
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x) x)
;;; Accessor SUBSEQ
(sequence-bounding-indices-test
(format t "~&/Accessor SUBSEQ~%")
(assert (string= (subseq string 0 5) "aaaaa"))
(assert (raises-error? (subseq string 0 6)))
- (assert (raises-error? (subseq string -1 5)))
+ (assert (raises-error? (subseq string (opaque-identity -1) 5)))
(assert (raises-error? (subseq string 4 2)))
(assert (raises-error? (subseq string 6)))
(assert (string= (setf (subseq string 0 5) "abcde") "abcde"))
(assert (string= (subseq string 0 5) "abcde"))
(reset)
(assert (raises-error? (setf (subseq string 0 6) "abcdef")))
- (assert (raises-error? (setf (subseq string -1 5) "abcdef")))
+ (assert (raises-error? (setf (subseq string (opaque-identity -1) 5) "abcdef")))
(assert (raises-error? (setf (subseq string 4 2) "")))
(assert (raises-error? (setf (subseq string 6) "ghij"))))
(assert (= (count #\a string :start 0 :end nil) 5))
(assert (= (count #\a string :start 0 :end 5) 5))
(assert (raises-error? (count #\a string :start 0 :end 6)))
- (assert (raises-error? (count #\a string :start -1 :end 5)))
+ (assert (raises-error? (count #\a string :start (opaque-identity -1) :end 5)))
(assert (raises-error? (count #\a string :start 4 :end 2)))
(assert (raises-error? (count #\a string :start 6 :end 9)))
(assert (= (count-if #'alpha-char-p string :start 0 :end nil) 5))
(assert (raises-error?
(count-if #'alpha-char-p string :start 0 :end 6)))
(assert (raises-error?
- (count-if #'alpha-char-p string :start -1 :end 5)))
+ (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(assert (raises-error?
(count-if #'alpha-char-p string :start 4 :end 2)))
(assert (raises-error?
(assert (raises-error?
(count-if-not #'alpha-char-p string :start 0 :end 6)))
(assert (raises-error?
- (count-if-not #'alpha-char-p string :start -1 :end 5)))
+ (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(assert (raises-error?
(count-if-not #'alpha-char-p string :start 4 :end 2)))
(assert (raises-error?
(assert (string= (fill string #\b :start 0 :end 5) "bbbbb"))
(assert (string= (fill string #\c :start 0 :end nil) "ccccc"))
(assert (raises-error? (fill string #\d :start 0 :end 6)))
- (assert (raises-error? (fill string #\d :start -1 :end 5)))
+ (assert (raises-error? (fill string #\d :start (opaque-identity -1) :end 5)))
(assert (raises-error? (fill string #\d :start 4 :end 2)))
(assert (raises-error? (fill string #\d :start 6 :end 9))))
(assert (char= (find #\a string :start 0 :end nil) #\a))
(assert (char= (find #\a string :start 0 :end 5) #\a))
(assert (raises-error? (find #\a string :start 0 :end 6)))
- (assert (raises-error? (find #\a string :start -1 :end 5)))
+ (assert (raises-error? (find #\a string :start (opaque-identity -1) :end 5)))
(assert (raises-error? (find #\a string :start 4 :end 2)))
(assert (raises-error? (find #\a string :start 6 :end 9)))
(assert (char= (find-if #'alpha-char-p string :start 0 :end nil) #\a))
(assert (raises-error?
(find-if #'alpha-char-p string :start 0 :end 6)))
(assert (raises-error?
- (find-if #'alpha-char-p string :start -1 :end 5)))
+ (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(assert (raises-error?
(find-if #'alpha-char-p string :start 4 :end 2)))
(assert (raises-error?
(assert (raises-error?
(find-if-not #'alpha-char-p string :start 0 :end 6)))
(assert (raises-error?
- (find-if-not #'alpha-char-p string :start -1 :end 5)))
+ (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(assert (raises-error?
(find-if-not #'alpha-char-p string :start 4 :end 2)))
(assert (raises-error?
(assert (null (mismatch string "aaaaa" :start1 0 :end1 nil)))
(assert (= (mismatch "aaab" string :start2 0 :end2 4) 3))
(assert (raises-error? (mismatch "aaaaaa" string :start2 0 :end2 6)))
- (assert (raises-error? (mismatch string "aaaaaa" :start1 -1 :end1 5)))
+ (assert (raises-error? (mismatch string "aaaaaa" :start1 (opaque-identity -1) :end1 5)))
(assert (raises-error? (mismatch string "" :start1 4 :end1 2)))
(assert (raises-error? (mismatch "aaaa" string :start2 6 :end2 9))))
(assert (= (parse-integer string :start 0 :end 5) 12345))
(assert (= (parse-integer string :start 0 :end nil) 12345))
(assert (raises-error? (parse-integer string :start 0 :end 6)))
- (assert (raises-error? (parse-integer string :start -1 :end 5)))
+ (assert (raises-error? (parse-integer string :start (opaque-identity -1) :end 5)))
(assert (raises-error? (parse-integer string :start 4 :end 2)))
(assert (raises-error? (parse-integer string :start 6 :end 9))))
:start 0 :end 6)))
(assert (raises-error? (parse-namestring string nil
*default-pathname-defaults*
- :start -1 :end 5)))
+ :start (opaque-identity -1) :end 5)))
(assert (raises-error? (parse-namestring string nil
*default-pathname-defaults*
:start 4 :end 2)))
(assert (= (position #\a string :start 0 :end nil) 0))
(assert (= (position #\a string :start 0 :end 5) 0))
(assert (raises-error? (position #\a string :start 0 :end 6)))
- (assert (raises-error? (position #\a string :start -1 :end 5)))
+ (assert (raises-error? (position #\a string :start (opaque-identity -1) :end 5)))
(assert (raises-error? (position #\a string :start 4 :end 2)))
(assert (raises-error? (position #\a string :start 6 :end 9)))
(assert (= (position-if #'alpha-char-p string :start 0 :end nil) 0))
(assert (raises-error?
(position-if #'alpha-char-p string :start 0 :end 6)))
(assert (raises-error?
- (position-if #'alpha-char-p string :start -1 :end 5)))
+ (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(assert (raises-error?
(position-if #'alpha-char-p string :start 4 :end 2)))
(assert (raises-error?
(assert (raises-error?
(position-if-not #'alpha-char-p string :start 0 :end 6)))
(assert (raises-error?
- (position-if-not #'alpha-char-p string :start -1 :end 5)))
+ (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(assert (raises-error?
(position-if-not #'alpha-char-p string :start 4 :end 2)))
(assert (raises-error?
(assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b)))
(assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b)))
(assert (raises-error? (read-from-string string nil nil :start 0 :end 6)))
- (assert (raises-error? (read-from-string string nil nil :start -1 :end 5)))
+ (assert (raises-error? (read-from-string string nil nil :start (opaque-identity -1) :end 5)))
(assert (raises-error? (read-from-string string nil nil :start 4 :end 2)))
(assert (raises-error? (read-from-string string nil nil :start 6 :end 9))))
(assert (equal (reduce #'list* string :from-end t :start 0 :end 5)
'(#\a #\b #\c #\d . #\e)))
(assert (raises-error? (reduce #'list* string :start 0 :end 6)))
- (assert (raises-error? (reduce #'list* string :start -1 :end 5)))
+ (assert (raises-error? (reduce #'list* string :start (opaque-identity -1) :end 5)))
(assert (raises-error? (reduce #'list* string :start 4 :end 2)))
(assert (raises-error? (reduce #'list* string :start 6 :end 9))))
(assert (equal (remove #\a string :start 0 :end nil) ""))
(assert (equal (remove #\a string :start 0 :end 5) ""))
(assert (raises-error? (remove #\a string :start 0 :end 6)))
- (assert (raises-error? (remove #\a string :start -1 :end 5)))
+ (assert (raises-error? (remove #\a string :start (opaque-identity -1) :end 5)))
(assert (raises-error? (remove #\a string :start 4 :end 2)))
(assert (raises-error? (remove #\a string :start 6 :end 9)))
(assert (equal (remove-if #'alpha-char-p string :start 0 :end nil) ""))
(assert (raises-error?
(remove-if #'alpha-char-p string :start 0 :end 6)))
(assert (raises-error?
- (remove-if #'alpha-char-p string :start -1 :end 5)))
+ (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(assert (raises-error?
(remove-if #'alpha-char-p string :start 4 :end 2)))
(assert (raises-error?
(assert (raises-error?
(remove-if-not #'alpha-char-p string :start 0 :end 6)))
(assert (raises-error?
- (remove-if-not #'alpha-char-p string :start -1 :end 5)))
+ (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(assert (raises-error?
(remove-if-not #'alpha-char-p string :start 4 :end 2)))
(assert (raises-error?
- (remove-if-not #'alpha-char-p string :start 6 :end 9)))
+ (remove-if-not #'alpha-char-p string :start 6 :end 9))))
+(sequence-bounding-indices-test
(format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT")
(assert (equal (delete #\a string :start 0 :end nil) ""))
(reset)
(reset)
(assert (raises-error? (delete #\a string :start 0 :end 6)))
(reset)
- (assert (raises-error? (delete #\a string :start -1 :end 5)))
+ (assert (raises-error? (delete #\a string :start (opaque-identity -1) :end 5)))
(reset)
(assert (raises-error? (delete #\a string :start 4 :end 2)))
(reset)
(delete-if #'alpha-char-p string :start 0 :end 6)))
(reset)
(assert (raises-error?
- (delete-if #'alpha-char-p string :start -1 :end 5)))
+ (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(reset)
(assert (raises-error?
(delete-if #'alpha-char-p string :start 4 :end 2)))
(delete-if-not #'alpha-char-p string :start 0 :end 6)))
(reset)
(assert (raises-error?
- (delete-if-not #'alpha-char-p string :start -1 :end 5)))
+ (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
(reset)
(assert (raises-error?
(delete-if-not #'alpha-char-p string :start 4 :end 2)))
(assert (string= (remove-duplicates string :start 0 :end 5) "a"))
(assert (string= (remove-duplicates string :start 0 :end nil) "a"))
(assert (raises-error? (remove-duplicates string :start 0 :end 6)))
- (assert (raises-error? (remove-duplicates string :start -1 :end 5)))
+ (assert (raises-error? (remove-duplicates string :start (opaque-identity -1) :end 5)))
(assert (raises-error? (remove-duplicates string :start 4 :end 2)))
(assert (raises-error? (remove-duplicates string :start 6 :end 9)))
(assert (string= (delete-duplicates string :start 0 :end 5) "a"))
(reset)
(assert (raises-error? (delete-duplicates string :start 0 :end 6)))
(reset)
- (assert (raises-error? (delete-duplicates string :start -1 :end 5)))
+ (assert (raises-error? (delete-duplicates string :start (opaque-identity -1) :end 5)))
(reset)
(assert (raises-error? (delete-duplicates string :start 4 :end 2)))
(reset)
string
:start2 0 :end2 nil) "bbbbb"))
(assert (raises-error? (replace string "ccccc" :start1 0 :end1 6)))
- (assert (raises-error? (replace string "ccccc" :start2 -1 :end2 5)))
+ (assert (raises-error? (replace string "ccccc" :start2 (opaque-identity -1) :end2 5)))
(assert (raises-error? (replace string "ccccc" :start1 4 :end1 2)))
(assert (raises-error? (replace string "ccccc" :start1 6 :end1 9))))
(assert (= (search "aa" string :start2 0 :end2 5) 0))
(assert (null (search string "aa" :start1 0 :end2 nil)))
(assert (raises-error? (search "aa" string :start2 0 :end2 6)))
- (assert (raises-error? (search "aa" string :start2 -1 :end2 5)))
+ (assert (raises-error? (search "aa" string :start2 (opaque-identity -1) :end2 5)))
(assert (raises-error? (search "aa" string :start2 4 :end2 2)))
(assert (raises-error? (search "aa" string :start2 6 :end2 9))))
;;; Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE,
;;; NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE
+(defmacro string-case-frob (fn)
+ `(progn
+ (assert (raises-error? (,fn string :start 0 :end 6)))
+ (assert (raises-error? (,fn string :start (opaque-identity -1) :end 5)))
+ (assert (raises-error? (,fn string :start 4 :end 2)))
+ (assert (raises-error? (,fn string :start 6 :end 9)))))
+
(sequence-bounding-indices-test
- (macrolet ((frob (fn)
- `(progn
- (assert (raises-error? (,fn string :start 0 :end 6)))
- (assert (raises-error? (,fn string :start -1 :end 5)))
- (assert (raises-error? (,fn string :start 4 :end 2)))
- (assert (raises-error? (,fn string :start 6 :end 9))))))
- (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...~%")
- (frob string-upcase)
- (frob string-downcase)
- (frob string-capitalize)
- (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE~%")
- (frob nstring-upcase)
- (frob nstring-downcase)
- (frob nstring-capitalize)))
+ (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...~%")
+ (string-case-frob string-upcase)
+ (string-case-frob string-downcase)
+ (string-case-frob string-capitalize)
+ (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE~%")
+ (string-case-frob nstring-upcase)
+ (string-case-frob nstring-downcase)
+ (string-case-frob nstring-capitalize))
;;; Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=,
;;; STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP,
;;; STRING-NOT-GREATERP, STRING-NOT-LESSP
+(defmacro string-predicate-frob (fn)
+ `(progn
+ (,fn string "abcde" :start1 0 :end1 5)
+ (,fn "fghij" string :start2 0 :end2 nil)
+ (assert (raises-error? (,fn string "klmno"
+ :start1 0 :end1 6)))
+ (assert (raises-error? (,fn "pqrst" string
+ :start2 (opaque-identity -1) :end2 5)))
+ (assert (raises-error? (,fn "uvwxy" string
+ :start1 4 :end1 2)))
+ (assert (raises-error? (,fn string "z" :start2 6 :end2 9)))))
(sequence-bounding-indices-test
- (macrolet ((frob (fn)
- `(progn
- (,fn string "abcde" :start1 0 :end1 5)
- (,fn "fghij" string :start2 0 :end2 nil)
- (assert (raises-error? (,fn string "klmno"
- :start1 0 :end1 6)))
- (assert (raises-error? (,fn "pqrst" string
- :start2 -1 :end2 5)))
- (assert (raises-error? (,fn "uvwxy" string
- :start1 4 :end1 2)))
- (assert (raises-error? (,fn string "z" :start2 6 :end2 9))))))
- (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...")
- (frob string=)
- (frob string/=)
- (frob string<)
- (frob string>)
- (frob string<=)
- (frob string>=)
- (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...~%")
- (frob string-equal)
- (frob string-not-equal)
- (frob string-lessp)
- (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP~%")
- (frob string-greaterp)
- (frob string-not-greaterp)
- (frob string-not-lessp)))
+ (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...")
+ (string-predicate-frob string=)
+ (string-predicate-frob string/=)
+ (string-predicate-frob string<)
+ (string-predicate-frob string>)
+ (string-predicate-frob string<=)
+ (string-predicate-frob string>=))
+(sequence-bounding-indices-test
+ (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...~%")
+ (string-predicate-frob string-equal)
+ (string-predicate-frob string-not-equal)
+ (string-predicate-frob string-lessp))
+(sequence-bounding-indices-test
+ (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP~%")
+ (string-predicate-frob string-greaterp)
+ (string-predicate-frob string-not-greaterp)
+ (string-predicate-frob string-not-lessp))
;;; Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT,
;;; NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
(assert (string= (substitute #\c #\a string :start 0 :end nil)
"ccccc"))
(assert (raises-error? (substitute #\b #\a string :start 0 :end 6)))
- (assert (raises-error? (substitute #\b #\a string :start -1 :end 5)))
+ (assert (raises-error? (substitute #\b #\a string :start (opaque-identity -1) :end 5)))
(assert (raises-error? (substitute #\b #\a string :start 4 :end 2)))
(assert (raises-error? (substitute #\b #\a string :start 6 :end 9)))
(assert (string= (substitute-if #\b #'alpha-char-p string
(assert (raises-error? (substitute-if #\b #'alpha-char-p string
:start 0 :end 6)))
(assert (raises-error? (substitute-if #\b #'alpha-char-p string
- :start -1 :end 5)))
+ :start (opaque-identity -1) :end 5)))
(assert (raises-error? (substitute-if #\b #'alpha-char-p string
:start 4 :end 2)))
(assert (raises-error? (substitute-if #\b #'alpha-char-p string
(assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
:start 0 :end 6)))
(assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
- :start -1 :end 5)))
+ :start (opaque-identity -1) :end 5)))
(assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
:start 4 :end 2)))
(assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
- :start 6 :end 9)))
+ :start 6 :end 9))))
+(sequence-bounding-indices-test
(format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT~%")
(assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb"))
(reset)
(reset)
(assert (raises-error? (nsubstitute #\b #\a string :start 0 :end 6)))
(reset)
- (assert (raises-error? (nsubstitute #\b #\a string :start -1 :end 5)))
+ (assert (raises-error? (nsubstitute #\b #\a string :start (opaque-identity -1) :end 5)))
(reset)
(assert (raises-error? (nsubstitute #\b #\a string :start 4 :end 2)))
(reset)
:start 0 :end 6)))
(reset)
(assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
- :start -1 :end 5)))
+ :start (opaque-identity -1) :end 5)))
(reset)
(assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
:start 4 :end 2)))
:start 0 :end 6)))
(reset)
(assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
- :start -1 :end 5)))
+ :start (opaque-identity -1) :end 5)))
(reset)
(assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
:start 4 :end 2)))
(assert (raises-error? (write-string string *standard-output*
:start 0 :end 6)))
(assert (raises-error? (write-string string *standard-output*
- :start -1 :end 5)))
+ :start (opaque-identity -1) :end 5)))
(assert (raises-error? (write-string string *standard-output*
:start 4 :end 2)))
(assert (raises-error? (write-string string *standard-output*
(assert (raises-error? (write-line string *standard-output*
:start 0 :end 6)))
(assert (raises-error? (write-line string *standard-output*
- :start -1 :end 5)))
+ :start (opaque-identity -1) :end 5)))
(assert (raises-error? (write-line string *standard-output*
:start 4 :end 2)))
(assert (raises-error? (write-line string *standard-output*
(with-input-from-string (s string :start 0 :end 6)
(read-char s))))
(assert (raises-error?
- (with-input-from-string (s string :start -1 :end 5)
+ (with-input-from-string (s string :start (opaque-identity -1) :end 5)
(read-char s))))
(assert (raises-error?
(with-input-from-string (s string :start 4 :end 2)
(assert-secondnil (sb-xc:subtypep t '(satisfies foo)))
(assert-secondnil (sb-xc:subtypep t '(and (satisfies foo) (satisfies bar))))
(assert-secondnil (sb-xc:subtypep t '(or (satisfies foo) (satisfies bar))))
- ;; FIXME: Enable these tests when bug 84 is fixed.
- #|
(assert-secondnil (sb-xc:subtypep '(satisfies foo) nil))
(assert-secondnil (sb-xc:subtypep '(and (satisfies foo) (satisfies bar))
nil))
(assert-secondnil (sb-xc:subtypep '(or (satisfies foo) (satisfies bar))
- nil))
- |#)
+ nil)))
;;; tests of 2-value quantifieroids FOO/TYPE
(macrolet ((2= (v1 v2 expr2)
(deftype bar () 'single-float)
(assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0))
0.0f0))
+
+;;; bug 260a
+(assert-t-t
+ (let* ((s (gensym))
+ (t1 (sb-kernel:specifier-type s)))
+ (eval `(defstruct ,s))
+ (sb-kernel:type= t1 (sb-kernel:specifier-type s))))
\f
;;; success
(quit :unix-status 104)
# provided with absolutely no warranty. See the COPYING and CREDITS
# files for more information.
+include ../src/runtime/Config
+
all: grovel_headers determine-endianness
clean:
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.78.vector-nil-string.15"
+"0.8.1.34"
projects / sbcl.git / commitdiff