"ANY" "ARGUMENT-COUNT-ERROR" "ASSEMBLE-FILE"
"ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION"
"ATTRIBUTES=" "BIND"
- "BYTE-BLT" ; doesn't logically belong here, but is name of VOP..
+ "BYTE-BLT"
"CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-OUT" "CALL-VARIABLE"
"CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN"
"CASE-BODY" "CATCH-BLOCK" "CHECK-CONS"
"BIT-BASH-XOR"
"BIT-INDEX" "BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR"
"BOOLE-CODE"
- "BYTE-SPECIFIER" "CALLABLE" "CASE-BODY-ERROR"
+ "BYTE-SPECIFIER"
+ "%BYTE-BLT"
+ "CALLABLE" "CASE-BODY-ERROR"
"CHARPOS"
"CHECK-FOR-CIRCULARITY" "CHECK-TYPE-ERROR"
"CLOSED-FLAME"
;; FIXME: %PRIMITIVE shouldn't be here. (I now know that %SYS
;; is for OS-dependent stuff. %PRIMITIVE should probably be in
;; SB!KERNEL.)
- "%PRIMITIVE" "%SP-BYTE-BLT" "%SP-FIND-CHARACTER"
- "%SP-FIND-CHARACTER-WITH-ATTRIBUTE"
- "%SP-REVERSE-FIND-CHARACTER-WITH-ATTRIBUTE"
+ "%PRIMITIVE" "%SP-FIND-CHARACTER"
"%STANDARD-CHAR-P"
"*LONG-SITE-NAME*" "*SHORT-SITE-NAME*"
"*STDERR*" "*STDIN*"
(declare (type (simple-array (unsigned-byte 8) 1) bv))
(declare (type sap sap))
(declare (type fixnum offset))
- ;; FIXME: Actually it looks as though this, and most other calls
- ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
- ;; Except that the DST-END-DST-START convention for the length is confusing.
- ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
- ;; DST-END argument with an N-BYTES argument?
+ ;; FIXME: Actually it looks as though this, and most other calls to
+ ;; COPY-TO-SYSTEM-AREA, could be written more concisely with
+ ;; %BYTE-BLT. Except that the DST-END-DST-START convention for the
+ ;; length is confusing. Perhaps I could rename %BYTE-BLT to
+ ;; %BYTE-BLIT (and correspondingly rename the corresponding VOP) and
+ ;; replace the DST-END argument with an N-BYTES argument?
(copy-to-system-area bv
(* sb!vm:vector-data-offset sb!vm:word-bits)
sap
(once-only ((len `(read-var-integer ,vec ,index)))
(once-only ((res `(make-string ,len)))
`(progn
- (%primitive byte-blt ,vec ,index ,res 0 ,len)
+ (%byte-blt ,vec ,index ,res 0 ,len)
(incf ,index ,len)
,res))))
(once-only ((n-bytes bytes))
(once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit)))
`(progn
- (%primitive byte-blt ,vec ,index ,n-res 0 ,n-bytes)
+ (%byte-blt ,vec ,index ,n-res 0 ,n-bytes)
(incf ,index ,n-bytes)
,n-res))))
(car entry)
(caddr entry))))))
-;;; Returns a string constructed from the sap, start, and end.
+;;; Return a string constructed from SAP, START, and END.
(defun string-from-sap (sap start end)
(declare (type index start end))
(let* ((length (- end start))
(* length sb!vm:byte-bits))
string))
-;;; the N-BIN method for FD-STREAMs. This blocks in UNIX-READ. It is
-;;; generally used where there is a definite amount of reading to be
-;;; done, so blocking isn't too problematical.
+;;; the N-BIN method for FD-STREAMs
+;;;
+;;; Note that this blocks in UNIX-READ. It is generally used where
+;;; there is a definite amount of reading to be done, so blocking
+;;; isn't too problematical.
(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
(declare (type fd-stream stream))
(declare (type index start requested))
(head (fd-stream-ibuf-head stream))
(tail (fd-stream-ibuf-tail stream))
(available (- tail head))
- (this-copy (min remaining-request available))
+ (n-this-copy (min remaining-request available))
(this-start (+ start total-copied))
+ (this-end (+ this-start n-this-copy))
(sap (fd-stream-ibuf-sap stream)))
(declare (type index remaining-request head tail available))
- (declare (type index this-copy))
+ (declare (type index n-this-copy))
;; Copy data from stream buffer into user's buffer.
- (if (typep buffer 'system-area-pointer)
- (system-area-copy sap (* head sb!vm:byte-bits)
- buffer (* this-start sb!vm:byte-bits)
- (* this-copy sb!vm:byte-bits))
- (copy-from-system-area sap (* head sb!vm:byte-bits)
- buffer (+ (* this-start sb!vm:byte-bits)
- (* sb!vm:vector-data-offset
- sb!vm:word-bits))
- (* this-copy sb!vm:byte-bits)))
- (incf (fd-stream-ibuf-head stream) this-copy)
- (incf total-copied this-copy)
+ (%byte-blt sap head buffer this-start this-end)
+ (incf (fd-stream-ibuf-head stream) n-this-copy)
+ (incf total-copied n-this-copy)
;; Maybe we need to refill the stream buffer.
(cond (;; If there were enough data in the stream buffer, we're done.
(= total-copied requested)
`(char-code (char-ref ,index))))
,@body))))
-;;; The codes of the characters of STRING from START to END are used
-;;; as indices into the TABLE, which is a U-Vector of 8-bit bytes.
-;;; When the number picked up from the table bitwise ANDed with MASK
-;;; is non-zero, the current index into the STRING is returned.
-;;;
-;;; (This corresponds to SCANC on the Vax.)
-(defun %sp-find-character-with-attribute (string start end table mask)
- (declare (type (simple-array (unsigned-byte 8) (256)) table)
- (type (or simple-string system-area-pointer) string)
- (fixnum start end mask))
- (maybe-sap-maybe-string (string)
- (do ((index start (1+ index)))
- ((>= index end) nil)
- (declare (fixnum index))
- (unless (zerop (logand (aref table (byte-ref index)) mask))
- (return index)))))
-
-;;; like %SP-FIND-CHARACTER-WITH-ATTRIBUTE, only sdrawkcaB
-(defun %sp-reverse-find-character-with-attribute (string start end table mask)
- (declare (type (or simple-string system-area-pointer) string)
- (fixnum start end mask)
- (type (array (unsigned-byte 8) (256)) table))
- (maybe-sap-maybe-string (string)
- (do ((index (1- end) (1- index)))
- ((< index start) nil)
- (declare (fixnum index))
- (unless (zerop (logand (aref table (byte-ref index)) mask))
- (return index)))))
-
;;; Search STRING for the CHARACTER from START to END. If the
;;; character is found, the corresponding index into STRING is
;;; returned, otherwise NIL is returned.
numbytes
eof-error-p))
((<= numbytes num-buffered)
- (%primitive sb!c:byte-blt
- in-buffer
- index
- buffer
- start
- (+ start numbytes))
+ (%byte-blt in-buffer index
+ buffer start (+ start numbytes))
(setf (lisp-stream-in-index stream) (+ index numbytes))
numbytes)
(t
(let ((end (+ start num-buffered)))
- (%primitive sb!c:byte-blt in-buffer index buffer start end)
+ (%byte-blt in-buffer index buffer start end)
(setf (lisp-stream-in-index stream) +in-buffer-length+)
(+ (funcall (lisp-stream-n-bin stream)
stream
(let* ((new-length (* current 2))
(new-workspace (make-string new-length)))
(declare (simple-string new-workspace))
- (%primitive sb!c:byte-blt
- workspace
- start
- new-workspace
- 0
- current)
+ (%byte-blt workspace start
+ new-workspace 0 current)
(setf workspace new-workspace)
(setf offset-current current)
(set-array-header buffer workspace new-length
(let* ((new-length (+ (the fixnum (* current 2)) string-len))
(new-workspace (make-string new-length)))
(declare (simple-string new-workspace))
- (%primitive sb!c:byte-blt
- workspace
- dst-start
- new-workspace
- 0
- current)
+ (%byte-blt workspace dst-start
+ new-workspace 0 current)
(setf workspace new-workspace)
(setf offset-current current)
(setf offset-dst-end dst-end)
new-length
nil))
(setf (fill-pointer buffer) dst-end))
- (%primitive sb!c:byte-blt
- string
- start
- workspace
- offset-current
- offset-dst-end)))
+ (%byte-blt string start
+ workspace offset-current offset-dst-end)))
dst-end))
(defun fill-pointer-misc (stream operation &optional arg1 arg2)
(setf *standard-output* (third old-streams))
(setf *error-output* (fourth old-streams)))))
(values))
+
+(defun %byte-blt (src src-start dst dst-start dst-end)
+ (%byte-blt src src-start dst dst-start dst-end))
(in-package "SB!C")
-;;; In copy propagation, we manipulate sets of TNs. We only consider TNs whose
-;;; sole write is by a MOVE VOP. This allows us to use a degenerate version of
-;;; reaching definitions: since each such TN has only one definition, the TN
-;;; can stand for the definition. We can get away with this simplification,
-;;; since the TNs that would be subject to copy propagation are nearly always
-;;; single-writer (mostly temps allocated to ensure evaluation order is
-;;; perserved). Only TNs written by MOVEs are interesting, since all we do
-;;; with this information is delete spurious MOVEs.
+;;; In copy propagation, we manipulate sets of TNs. We only consider
+;;; TNs whose sole write is by a MOVE VOP. This allows us to use a
+;;; degenerate version of reaching definitions: since each such TN has
+;;; only one definition, the TN can stand for the definition. We can
+;;; get away with this simplification, since the TNs that would be
+;;; subject to copy propagation are nearly always single-writer
+;;; (mostly temps allocated to ensure evaluation order is perserved).
+;;; Only TNs written by MOVEs are interesting, since all we do with
+;;; this information is delete spurious MOVEs.
;;;
-;;; There are additional semantic constraints on whether a TN can be considered
-;;; to be a copy. See TN-IS-A-COPY-OF.
+;;; There are additional semantic constraints on whether a TN can be
+;;; considered to be a copy. See TN-IS-A-COPY-OF.
;;;
-;;; If a TN is in the IN set for a block, that TN is a copy of a TN which still
-;;; has the same value it had at the time the move was done. Any reference
-;;; to a TN in the IN set can be replaced with a reference to the TN moved
-;;; from. When we delete all reads of such a TN, we can delete the MOVE VOP.
-;;; IN is computed as the intersection of OUT for all the predecessor blocks.
+;;; If a TN is in the IN set for a block, that TN is a copy of a TN
+;;; which still has the same value it had at the time the move was
+;;; done. Any reference to a TN in the IN set can be replaced with a
+;;; reference to the TN moved from. When we delete all reads of such a
+;;; TN, we can delete the MOVE VOP. IN is computed as the intersection
+;;; of OUT for all the predecessor blocks.
;;;
-;;; In this flow analysis scheme, the KILL set is the set of all interesting
-;;; TNs where the copied TN is modified by the block (in any way.)
+;;; In this flow analysis scheme, the KILL set is the set of all
+;;; interesting TNs where the copied TN is modified by the block (in
+;;; any way.)
;;;
-;;; GEN is the set of all interesting TNs that are copied in the block (whose
-;;; write appears in the block.)
+;;; GEN is the set of all interesting TNs that are copied in the block
+;;; (whose write appears in the block.)
;;;
;;; OUT is (union (difference IN KILL) GEN)
;;; If TN is subject to copy propagation, then return the TN it is a copy
;;; of, otherwise NIL.
;;;
-;;; We also only consider TNs where neither the TN nor the copied TN are wired
-;;; or restricted. If we extended the life of a wired or restricted TN,
-;;; register allocation might fail, and we can't substitute arbitrary things
-;;; for references to wired or restricted TNs, since the reader may be
-;;; expencting the argument to be in a particular place (as in a passing
-;;; location.)
+;;; We also only consider TNs where neither the TN nor the copied TN
+;;; are wired or restricted. If we extended the life of a wired or
+;;; restricted TN, register allocation might fail, and we can't
+;;; substitute arbitrary things for references to wired or restricted
+;;; TNs, since the reader may be expencting the argument to be in a
+;;; particular place (as in a passing location.)
;;;
-;;; The TN must be a :NORMAL TN. Other TNs might have hidden references or be
-;;; otherwise bizarre.
+;;; The TN must be a :NORMAL TN. Other TNs might have hidden
+;;; references or be otherwise bizarre.
;;;
-;;; A TN is also inelegible if it has interned name, policy is such that we
-;;; would dump it in the debug vars, and speed is not 3.
+;;; A TN is also inelegible if it has interned name, policy is such
+;;; that we would dump it in the debug vars, and speed is not 3.
;;;
-;;; The SCs of the TN's primitive types is a subset of the SCs of the copied
-;;; TN. Moves between TNs of different primitive type SCs may need to be
-;;; changed into coercions, so we can't squeeze them out. The reason for
-;;; testing for subset of the SCs instead of the same primitive type is
-;;; that this test lets T be substituted for LIST, POSITIVE-FIXNUM for FIXNUM,
-;;; etc. Note that more SCs implies fewer possible values, or a subtype
-;;; relationship, since more SCs implies more possible representations.
+;;; The SCs of the TN's primitive types is a subset of the SCs of the
+;;; copied TN. Moves between TNs of different primitive type SCs may
+;;; need to be changed into coercions, so we can't squeeze them out.
+;;; The reason for testing for subset of the SCs instead of the same
+;;; primitive type is that this test lets T be substituted for LIST,
+;;; POSITIVE-FIXNUM for FIXNUM, etc. Note that more SCs implies fewer
+;;; possible values, or a subtype relationship, since more SCs implies
+;;; more possible representations.
(defun tn-is-copy-of (tn)
(declare (type tn tn))
(declare (inline subsetp))
(or (= speed 3) (< debug 2)))))
arg-tn)))))))
-;;; Init the sets in Block for copy propagation. To find Gen, we just look
-;;; for MOVE vops, and then see whether the result is a eligible copy TN. To
-;;; find Kill, we must look at all VOP results, seeing whether any of the
-;;; reads of the written TN are copies for eligible TNs.
+;;; Init the sets in Block for copy propagation. To find Gen, we just
+;;; look for MOVE vops, and then see whether the result is a eligible
+;;; copy TN. To find Kill, we must look at all VOP results, seeing
+;;; whether any of the reads of the written TN are copies for eligible
+;;; TNs.
(defun init-copy-sets (block)
(declare (type cblock block))
(let ((kill (make-sset))
(setf (block-gen block) gen))
(values))
-;;; Do the flow analysis step for copy propagation on Block. We rely on OUT
-;;; being initialized to GEN, and use SSET-UNION-OF-DIFFERENCE to incrementally
-;;; build the union in OUT, rather than replacing OUT each time.
+;;; Do the flow analysis step for copy propagation on Block. We rely
+;;; on OUT being initialized to GEN, and use SSET-UNION-OF-DIFFERENCE
+;;; to incrementally build the union in OUT, rather than replacing OUT
+;;; each time.
(defun copy-flow-analysis (block)
(declare (type cblock block))
(let* ((pred (block-pred block))
(defevent copy-deleted-move "Copy propagation deleted a move.")
-;;; Return true if Arg is a reference to a TN that we can copy propagate to.
-;;; In addition to dealing with copy chains (as discussed below), we also throw
-;;; out references that are arguments to a local call, since IR2tran introduces
-;;; tempes in that context to preserve parallel assignment semantics.
+;;; Return true if ARG is a reference to a TN that we can copy
+;;; propagate to. In addition to dealing with copy chains (as
+;;; discussed below), we also discard references that are arguments
+;;; to a local call, since IR2tran introduces temps in that context
+;;; to preserve parallel assignment semantics.
(defun ok-copy-ref (vop arg in original-copy-of)
(declare (type vop vop) (type tn arg) (type sset in)
(type hash-table original-copy-of))
(error "Couldn't find REF?"))
(length (template-arg-types info))))))))
-;;; Make use of the result of flow analysis to eliminate copies. We scan
-;;; the VOPs in block, propagating copies and keeping our IN set in sync.
+;;; Make use of the result of flow analysis to eliminate copies. We
+;;; scan the VOPs in block, propagating copies and keeping our IN set
+;;; in sync.
;;;
;;; Original-Copy-Of is an EQ hash table that we use to keep track of
-;;; renamings when there are copy chains, i.e. copies of copies. When we see
-;;; copy of a copy, we enter the first copy in the table with the second copy
-;;; as a key. When we see a reference to a TN in a copy chain, we can only
-;;; substitute the first copied TN for the reference when all intervening
-;;; copies in the copy chain are also available. Otherwise, we just leave the
-;;; reference alone. It is possible that we might have been able to reference
-;;; one of the intermediate copies instead, but that copy might have already
-;;; been deleted, since we delete the move immediately when the references go
-;;; to zero.
+;;; renamings when there are copy chains, i.e. copies of copies. When
+;;; we see copy of a copy, we enter the first copy in the table with
+;;; the second copy as a key. When we see a reference to a TN in a
+;;; copy chain, we can only substitute the first copied TN for the
+;;; reference when all intervening copies in the copy chain are also
+;;; available. Otherwise, we just leave the reference alone. It is
+;;; possible that we might have been able to reference one of the
+;;; intermediate copies instead, but that copy might have already been
+;;; deleted, since we delete the move immediately when the references
+;;; go to zero.
;;;
-;;; To understand why we always can to the substitution when the copy chain
-;;; recorded in the Original-Copy-Of table hits NIL, note that we make an entry
-;;; in the table iff we change the arg of a copy. If an entry is not in the
-;;; table, it must be that we hit a move which *originally* referenced our
-;;; Copy-Of TN. If all the intervening copies reach our reference, then
-;;; Copy-Of must reach the reference.
+;;; To understand why we always can to the substitution when the copy
+;;; chain recorded in the Original-Copy-Of table hits NIL, note that
+;;; we make an entry in the table iff we change the arg of a copy. If
+;;; an entry is not in the table, it must be that we hit a move which
+;;; *originally* referenced our Copy-Of TN. If all the intervening
+;;; copies reach our reference, then Copy-Of must reach the reference.
;;;
-;;; Note that due to our restricting copies to single-writer TNs, it will
-;;; always be the case that when the first copy in a chain reaches the
-;;; reference, all intervening copies reach also reach the reference. We
-;;; don't exploit this, since we have to work backward from the last copy.
+;;; Note that due to our restricting copies to single-writer TNs, it
+;;; will always be the case that when the first copy in a chain
+;;; reaches the reference, all intervening copies reach also reach the
+;;; reference. We don't exploit this, since we have to work backward
+;;; from the last copy.
;;;
-;;; In this discussion, we are really only playing with the tail of the true
-;;; copy chain for which all of the copies have already had PROPAGATE-COPIES
-;;; done on them. But, because we do this pass in DFO, it is virtually always
-;;; the case that we will process earlier copies before later ones. In
-;;; perverse cases (non-reducible flow graphs), we just miss some optimization
-;;; opportinities.
+;;; In this discussion, we are really only playing with the tail of
+;;; the true copy chain for which all of the copies have already had
+;;; PROPAGATE-COPIES done on them. But, because we do this pass in
+;;; DFO, it is virtually always the case that we will process earlier
+;;; copies before later ones. In perverse cases (non-reducible flow
+;;; graphs), we just miss some optimization opportinities.
(defun propagate-copies (block original-copy-of)
(declare (type cblock block) (type hash-table original-copy-of))
(let ((in (block-in block)))
(simple-unboxed-array (*)) index index)
null
())
+
+;;; (not really a bit-bashing routine, but starting to take over from
+;;; bit-bashing routines in byte-sized copies as of sbcl-0.6.12.29:)
+(defknown %byte-blt
+ ((or (simple-unboxed-array (*)) system-area-pointer) index
+ (or (simple-unboxed-array (*)) system-area-pointer) index index)
+ null
+ ())
\f
;;;; code/function/fdefn object manipulation routines
(setf (%raw-bits result-bit-array index)
(32bit-logical-not (%raw-bits bit-array index))))))
\f
-;;;; primitive translator for BYTE-BLT
+;;;; BYTE-BLT
(def-primitive-translator byte-blt (src src-start dst dst-start dst-end)
;; FIXME: CMU CL had a hairier implementation of this. It had the
;; small problem that it didn't work for large (>16M) values of
;; SRC-START or DST-START. However, it might have been more
- ;; efficient. In particular, I haven't checked how much the foreign
- ;; function call costs us here. My guess is that if the overhead is
- ;; acceptable for SQRT and COS, it's acceptable here, but this
- ;; should probably be checked. -- WHN
- (once-only ((dst-start dst-start))
- `(flet ((sap (thing)
+ ;; efficient. In particular, I don't really know how much the
+ ;; foreign function call costs us here. My guess is that if the
+ ;; overhead is acceptable for SQRT and COS, it's acceptable here,
+ ;; but this should probably be checked. -- WHN
+ (once-only ((src-start src-start)
+ (dst-start dst-start))
+ `(flet ((->sap (thing)
(etypecase thing
(system-area-pointer thing)
+ ;; FIXME: The code here rather relies on the simple
+ ;; unboxed array here having byte-sized entries. That
+ ;; should be asserted explicitly, I just haven't found
+ ;; a concise way of doing it. (It would be nice to
+ ;; declare it in the DEFKNOWN too.)
((simple-unboxed-array (*)) (vector-sap thing)))))
- (declare (inline sap))
+ (declare (inline ->sap))
(without-gcing
- (memmove (sap+ (sap ,dst) ,dst-start)
- (sap+ (sap ,src) ,src-start)
- (- ,dst-end ,dst-start))))))
+ (memmove (sap+ (->sap ,dst) ,dst-start)
+ (sap+ (->sap ,src) ,src-start)
+ (- ,dst-end ,dst-start)))
+ nil)))
+
+;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA
+;;; stuff (with all the associated bit-index cruft and overflow
+;;; issues) even for byte moves. In SBCL, we're converting to byte
+;;; moves as problems are discovered with the old code, and this is
+;;; currently (ca. sbcl-0.6.12.30) the main interface for code in
+;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the
+;;; ideal interface, though, and it probably deserves some thought.
+(deftransform %byte-blt ((a1 a2 a3 a4 a5) (t t t t t))
+ '(%primitive byte-blt a1 a2 a3 a4 a5))
\f
;;;; transforms for EQL of floating point values
(assert (not (subtypep 'symbol 'keyword)))
(assert (subtypep 'ratio 'real))
(assert (subtypep 'ratio 'number))
+\f
+;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to allow
+;;;; inline type tests for CONDITIONs and STANDARD-OBJECTs, and generally
+;;;; be nicer, and Martin Atzmueller ported the patches.
+;;;; They look nice but they're nontrivial enough that it's not obvious
+;;;; from inspection that everything is OK. Let's make sure that things
+;;;; still basically work.
-;;; Pierre Mai rewrote the CMU CL type test system to allow inline
-;;; type tests for CONDITIONs and STANDARD-OBJECTs, and generally be
-;;; nicer, and Martin Atzmueller ported the patches. They look nice
-;;; but they're nontrivial enough that it's not obvious from
-;;; inspection that everything is OK. Let's make sure that things
-;;; still basically work.
-(defstruct foo1)
-(defstruct (foo2 (:include foo1))
+;; structure type tests setup
+(defstruct structure-foo1)
+(defstruct (structure-foo2 (:include structure-foo1))
x)
-(defstruct (foo3 (:include foo2)))
-(defstruct (foo4 (:include foo3))
+(defstruct (structure-foo3 (:include structure-foo2)))
+(defstruct (structure-foo4 (:include structure-foo3))
y z)
-(assert (typep (make-foo3) 'foo2))
-(assert (not (typep (make-foo1) 'foo4)))
-(assert (null (ignore-errors (setf (foo2-x (make-foo1)) 11))))
-;;; (More tests here would be nice before merging the patches. More
-;;; tests for STRUCTURE-OBJECT, tests for CONDITION, tests for
-;;; STANDARD-OBJECT, compiled tests to make sure that the inline
-;;; versions of the tests work..)
+
+;; structure-class tests setup
+(defclass structure-class-foo1 () () (:metaclass cl:structure-class))
+(defclass structure-class-foo2 (structure-class-foo1)
+ () (:metaclass cl:structure-class))
+(defclass structure-class-foo3 (structure-class-foo2)
+ () (:metaclass cl:structure-class))
+(defclass structure-class-foo4 (structure-class-foo3)
+ () (:metaclass cl:structure-class))
+
+;; standard-class tests setup
+(defclass standard-class-foo1 () () (:metaclass cl:standard-class))
+(defclass standard-class-foo2 (standard-class-foo1)
+ () (:metaclass cl:standard-class))
+(defclass standard-class-foo3 (standard-class-foo2)
+ () (:metaclass cl:standard-class))
+(defclass standard-class-foo4 (standard-class-foo3)
+ () (:metaclass cl:standard-class))
+
+;; condition tests setup
+(define-condition condition-foo1 (condition) ())
+(define-condition condition-foo2 (condition-foo1) ())
+(define-condition condition-foo3 (condition-foo2) ())
+(define-condition condition-foo4 (condition-foo3) ())
+
+(fmakunbound 'test-inline-type-tests)
+(defun test-inline-type-tests ()
+ ;; structure type tests
+ (assert (typep (make-structure-foo3) 'structure-foo2))
+ (assert (not (typep (make-structure-foo1) 'structure-foo4)))
+ (assert (null (ignore-errors
+ (setf (structure-foo2-x (make-structure-foo1)) 11))))
+
+ ;; structure-class tests
+ (assert (typep (make-instance 'structure-class-foo3)
+ 'structure-class-foo2))
+ (assert (not (typep (make-instance 'structure-class-foo1)
+ 'structure-class-foo4)))
+ (assert (null (ignore-errors
+ (setf (slot-value (make-instance 'structure-class-foo1) 'x)
+ 11))))
+
+ ;; standard-class tests
+ (assert (typep (make-instance 'standard-class-foo3)
+ 'standard-class-foo2))
+ (assert (not (typep (make-instance 'standard-class-foo1)
+ 'standard-class-foo4)))
+ (assert (null (ignore-errors
+ (setf (slot-value (make-instance 'standard-class-foo1) 'x)
+ 11))))
+
+ ;; condition tests
+ (assert (typep (make-condition 'condition-foo3)
+ 'condition-foo2))
+ (assert (not (typep (make-condition 'condition-foo1)
+ 'condition-foo4)))
+ (assert (null (ignore-errors
+ (setf (slot-value (make-condition 'condition-foo1) 'x)
+ 11))))
+
+ (assert (eq (car (sb-kernel:class-direct-superclasses (find-class
+ 'simple-condition)))
+ (find-class 'condition)))
+
+ (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
+ 'simple-condition)))
+ (sb-pcl:find-class 'condition)))
+ (assert (null (set-difference
+ (sb-pcl:class-direct-subclasses (sb-pcl:find-class
+ 'simple-condition))
+ (mapcar #'sb-pcl:find-class '(simple-type-error simple-error
+ sb-int:simple-style-warning)))))
+ ;; precedence lists
+ (assert (equal (sb-pcl:class-precedence-list
+ (sb-pcl:find-class 'simple-condition))
+ (mapcar #'sb-pcl:find-class '(simple-condition condition
+ sb-kernel:instance t))))
+
+ ;; stream classes
+ (assert (null (sb-kernel:class-direct-superclasses (find-class
+ 'fundamental-stream))))
+ (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
+ 'fundamental-stream))
+ (mapcar #'sb-pcl:find-class '(standard-object stream))))
+ (assert (null (set-difference
+ (sb-pcl:class-direct-subclasses (sb-pcl:find-class
+ 'fundamental-stream))
+ (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
+ fundamental-character-stream
+ fundamental-output-stream
+ fundamental-input-stream)))))
+ (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
+ 'fundamental-stream))
+ (mapcar #'sb-pcl:find-class '(fundamental-stream
+ standard-object
+ sb-pcl::std-object
+ sb-pcl::slot-object
+ stream
+ sb-kernel:instance
+ t))))
+ (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
+ 'fundamental-stream))
+ (mapcar #'sb-pcl:find-class '(fundamental-stream
+ standard-object
+ sb-pcl::std-object
+ sb-pcl::slot-object stream
+ sb-kernel:instance t)))))
+
+;;; inline-type tests:
+;;; Test the interpreted version.
+(test-inline-type-tests)
+;;; Test the compiled version.
+(compile nil #'test-inline-type-tests)
+(test-inline-type-tests)
;;; success
(quit :unix-status 104)
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.12.29"
+"0.6.12.30"
projects / sbcl.git / commitdiff