Implemented EXT:TRULY-THE and made THE expand to either EXT:TRULY-THE or...

Implemented EXT:TRULY-THE and made THE expand to either EXT:TRULY-THE or EXT:CHECKED-VALUE depending on the optimization settings.
parent f109f94a
......@@ -165,6 +165,13 @@ ECL 11.7.1:
- In pathnames, ".." is translated to :UP, not :BACK.
- ECL introduces two special forms, EXT:CHECKED-VALUE and EXT:TRULY-THE, which
have the same syntax as THE, but in the first case lead to a type assertion
at low safety levels and in the second case lead to an unchecked
declaration. By default THE maps to EXT:CHECKED-VALUE (as in SBCL), but this
may be controlled globally using the declaration/proclamation
EXT:THE-IS-CHECKED.
;;; Local Variables: ***
;;; mode:text ***
;;; fill-column:79 ***
......
......@@ -334,6 +334,7 @@ static compiler_record database[] = {
{@'symbol-macrolet', c_symbol_macrolet, 0},
{@'tagbody', c_tagbody, 1},
{@'the', c_the, 0},
{@'ext::truly-the', c_the, 0},
{@'throw', c_throw, 1},
{@'unwind-protect', c_unwind_protect, 1},
{@'values', c_values, 1},
......
......@@ -2218,5 +2218,8 @@ cl_symbols[] = {
{KEY_ "WEAKNESS", KEYWORD, NULL, -1, OBJNULL},
{EXT_ "HASH-TABLE-WEAKNESS", EXT_ORDINARY, si_hash_table_weakness, 1, OBJNULL},
{EXT_ "TRULY-THE", EXT_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "CHECKED-VALUE", EXT_ORDINARY, NULL, -1, OBJNULL},
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};
......@@ -2218,5 +2218,8 @@ cl_symbols[] = {
{KEY_ "WEAKNESS",NULL},
{EXT_ "HASH-TABLE-WEAKNESS","si_hash_table_weakness"},
{EXT_ "TRULY-THE",NULL},
{EXT_ "CHECKED-VALUE",NULL},
/* Tag for end of list */
{NULL,NULL}};
......@@ -189,7 +189,7 @@
(location (slot-definition-location slotd)))
(cond ((ext:fixnump location)
;; local slot
(si:instance-ref instance (the fixnum location)))
(si:instance-ref instance (truly-the fixnum location)))
((consp location)
;; shared slot
(car location))
......@@ -203,7 +203,7 @@
(location (slot-definition-location slotd)))
(cond ((ext:fixnump location)
;; local slot
(si:instance-set instance (the fixnum location) val))
(si:instance-set instance (truly-the fixnum location) val))
((consp location)
;; shared slot
(setf (car location) val))
......@@ -232,7 +232,7 @@
(let* ((location (slot-definition-location slotd)))
(cond ((ext:fixnump location)
;; local slot
(si:sl-makunbound instance (the fixnum location)))
(si:sl-makunbound instance (truly-the fixnum location)))
((consp location)
;; shared slot
(setf (car location) (unbound)))
......
......@@ -98,7 +98,7 @@
(cond ((null old-class)
(find-class 'standard-method))
((symbolp old-class)
(find-class (the symbol old-class)))
(find-class (truly-the symbol old-class)))
(t
old-class))))
(si::instance-sig-set gfun)
......
......@@ -10,7 +10,7 @@
;;;; See file '../Copyright' for full details.
(defpackage "CLOS"
(:use "CL")
(:use "CL" "EXT")
(:import-from "SI" "UNBOUND" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP"
"SIMPLE-PROGRAM-ERROR"))
......
......@@ -582,11 +582,11 @@ because it contains a reference to the undefined class~% ~A"
(ensure-up-to-date-instance self)
(let* ((class (si:instance-class self))
(table (slot-table class))
(slotd (the slot-definition (gethash slot-name table)))
(slotd (truly-the slot-definition (gethash slot-name table)))
(index (slot-definition-location slotd))
(value (if (si::fixnump index)
(si:instance-ref self (the fixnum index))
(car (the cons index)))))
(si:instance-ref self (truly-the fixnum index))
(car (truly-the cons index)))))
(if (si:sl-boundp value)
value
(values (slot-unbound (class-of self) self slot-name)))))
......@@ -596,11 +596,11 @@ because it contains a reference to the undefined class~% ~A"
(ensure-up-to-date-instance self)
(let* ((class (si:instance-class self))
(table (slot-table class))
(slotd (the slot-definition (gethash slot-name table)))
(slotd (truly-the slot-definition (gethash slot-name table)))
(index (slot-definition-location slotd)))
(if (si::fixnump index)
(si:instance-set self (the fixnum index) value)
(rplaca (the cons index) value)))))))
(si:instance-set self (truly-the fixnum index) value)
(rplaca (truly-the cons index) value)))))))
(defun std-class-sealed-accessors (index)
(declare (si::c-local)
......
......@@ -80,7 +80,7 @@
;; Then we may fill the array with a given value
(when initial-element-supplied-p
(setf form `(si::fill-array-with-elt ,form ,initial-element 0 nil)))
(setf form `(the (array ,guessed-element-type ,dimensions-type)
(setf form `(truly-the (array ,guessed-element-type ,dimensions-type)
,form))))
form)
......@@ -106,7 +106,7 @@
(declare (fixnum index dimension)
(:read-only index dimension))
(cond ((< index dimension)
(sys::fill-pointer-set vector (the fixnum (+ 1 index)))
(sys::fill-pointer-set vector (truly-the fixnum (+ 1 index)))
(sys::aset vector index value)
index)
(t ,(if extend
......@@ -216,12 +216,12 @@
for dim-var in dim-names
when (plusp i)
collect `(setf %output-var
(the ext:array-index (* %output-var ,dim-var)))
(truly-the ext:array-index (* %output-var ,dim-var)))
collect `(let ((%ndx-var ,index))
(declare (ext:array-index %ndx-var))
,(and check `(check-index-in-bounds ,a %ndx-var ,dim-var))
(setf %output-var
(the ext:array-index (+ %output-var %ndx-var)))))
(truly-the ext:array-index (+ %output-var %ndx-var)))))
%output-var))))
;(trace c::expand-row-major-index c::expand-aset c::expand-aref)
......
......@@ -35,8 +35,8 @@
(declare (type (integer 0 1023) hash)
(type (array t (*)) ,cache-name))
(if (and elt ,@(loop for arg in lambda-list
collect `(,test (pop (the cons elt)) ,arg)))
(first (the cons elt))
collect `(,test (pop (truly-the cons elt)) ,arg)))
(first (truly-the cons elt))
(let ((output (,name ,@lambda-list)))
(setf (aref ,cache-name hash) (list ,@lambda-list output))
output))))))))
......
......@@ -29,7 +29,7 @@
(integerp (setq pos (third arg1)))
(<= (+ size pos) len)
(subtypep (result-type (second args)) 'FIXNUM))
`(the fixnum (ldb1 ,size ,pos ,(second args)))
`(truly-the fixnum (ldb1 ,size ,pos ,(second args)))
whole)))
;;;
......
......@@ -132,9 +132,9 @@
(%iterator ,iterator))
(declare (optimize (safety 0)))
(if (si::fixnump %iterator)
(let ((%iterator (1+ (the fixnum %iterator))))
(let ((%iterator (1+ (truly-the fixnum %iterator))))
(declare (fixnum %iterator))
(and (< %iterator (length (the vector %seq)))
(and (< %iterator (length (truly-the vector %seq)))
%iterator))
(cons-cdr %iterator)))))
......
......@@ -145,7 +145,7 @@
(type ,first ,var2))
(AND (TYPEP ,var1 ',first)
(locally (declare (optimize (speed 3) (safety 0) (space 0)))
(setf ,var2 (the ,first ,var1))
(setf ,var2 (truly-the ,first ,var1))
(AND ,@(expand-in-interval-p var2 rest)))))))
;;
;; (SATISFIES predicate)
......@@ -177,7 +177,7 @@
(let* ((list-var (gensym))
(typed-var (if (policy-assume-no-errors env)
list-var
`(the cons ,list-var))))
`(truly-the cons ,list-var))))
`(block nil
(let* ((,list-var ,expression))
(si::while ,list-var
......
......@@ -266,6 +266,9 @@
(define-policy check-nargs :on safety 1 :only-on check-arguments-type 1
"Check that the number of arguments a function receives is within bounds")
(define-policy the-is-checked :on safety 1
"THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE.")
;;
;; INLINING POLICY
;;
......
......@@ -23,7 +23,12 @@
(cmperr "The declaration ~s was found in a bad place." (cons 'DECLARE args)))
(defun c1the (args)
(check-args-number 'THE args 2 2)
(if (policy-the-is-checked)
(c1checked-value args)
(c1truly-the args)))
(defun c1truly-the (args)
(check-args-number 'TRULY-THE args 2 2)
(let* ((form (c1expr (second args)))
(the-type (first args))
type)
......
......@@ -120,6 +120,7 @@
(quote . c1quote) ; c1special
(function . c1function) ; c1special
(the . c1the) ; c1special
(ext:truly-the . c1truly-the) ; c1special
(eval-when . c1eval-when) ; c1special
(declare . c1declare) ; c1special
(ext:compiler-let . c1compiler-let) ; c1special
......
......@@ -118,7 +118,7 @@
`(let* ((%checked-value ,value))
(declare (:read-only %checked-value))
,(expand-type-assertion '%checked-value type *cmp-env* nil)
(the ,type %checked-value)))))
(truly-the ,type %checked-value)))))
(make-c1form* 'CHECKED-VALUE
:type type
:args type form (c1expr full-check)))))))
......
......@@ -131,7 +131,7 @@
;; later due to this assertion...
(setf (var-type var) t
checks (list* `(type-assertion ,name ,type) checks)
new-auxs (list* `(the ,type ,name) name new-auxs))
new-auxs (list* `(truly-the ,type ,name) name new-auxs))
;; Or simply enforce the variable's type.
(setf (var-type var) (type-and (var-type var) type)))
finally
......@@ -177,7 +177,7 @@
(with-clean-symbols (%value)
`(let* ((%value ,value))
,(type-error-check '%value (replace-invalid-types type))
(the ,type %value))))))
(truly-the ,type %value))))))
(defun replace-invalid-types (type)
;; Some types which are acceptable in DECLARE are not
......
......@@ -253,13 +253,13 @@
(return nil))
(flag
(setf flag nil
fast (cdr (the cons fast))))
fast (cdr (truly-the cons fast))))
((eq slow fast)
(return nil))
(t
(setf flag t
slow (cdr (the cons slow))
fast (cdr (the cons fast)))))
slow (cdr (truly-the cons slow))
fast (cdr (truly-the cons fast)))))
finally (return l)))
(defun check-args-number (operator args &optional (min 0) (max most-positive-fixnum))
......
......@@ -127,7 +127,7 @@ INDEXes must be equal to the rank of ARRAY."
(do* ((r (array-rank array))
(i 0 (1+ i))
(j 0)
(s indices (cdr (the cons s))))
(s indices (cdr (truly-the cons s))))
((null s)
(when (< i r)
(indexing-error array indices))
......@@ -135,7 +135,7 @@ INDEXes must be equal to the rank of ARRAY."
(declare (ext:array-index j)
(fixnum i r))
(let* ((d (array-dimension array i))
(o (car (the cons s)))
(o (car (truly-the cons s)))
ndx)
(declare (ext:array-index ndx))
(unless (and (typep o 'fixnum)
......@@ -267,11 +267,11 @@ value of the fill-pointer becomes too large. Otherwise, returns the new fill-
pointer as the value."
;; FILL-POINTER asserts vector is a vector
(let* ((fp (fill-pointer vector))
(vector (the vector vector)))
(vector (truly-the vector vector)))
(declare (optimize (safety 0)))
(cond ((< fp (array-total-size vector))
(sys:aset vector fp new-element)
(sys:fill-pointer-set vector (the ext:array-index (1+ fp)))
(sys:fill-pointer-set vector (truly-the ext:array-index (1+ fp)))
fp)
(t nil))))
......@@ -283,7 +283,7 @@ the fill-pointer becomes too large, extends VECTOR for N more elements.
Returns the new value of the fill-pointer."
;; FILL-POINTER asserts vector is a vector
(let* ((fp (fill-pointer vector))
(vector (the vector vector)))
(vector (truly-the vector vector)))
(declare (optimize (safety 0)))
(let ((d (array-total-size vector)))
(unless (< fp d)
......@@ -302,7 +302,7 @@ to by the new fill-pointer. Signals an error if the old value of the fill-
pointer is 0 already."
;; FILL-POINTER asserts vector is a vector and has fill pointer
(let* ((fp (fill-pointer vector))
(vector (the vector vector)))
(vector (truly-the vector vector)))
(declare (ext:array-index fp)
(optimize (safety 0)))
(when (zerop fp)
......
......@@ -74,20 +74,20 @@
`(integer 1 ,most-positive-fixnum))
(defun negative-fixnum-p (p)
(and (si::fixnump p) (minusp (the fixnum p))))
(and (si::fixnump p) (minusp (truly-the fixnum p))))
(defun positive-fixnum-p (p)
(and (si::fixnump p) (plusp (the fixnum p))))
(and (si::fixnump p) (plusp (truly-the fixnum p))))
(defun non-negative-fixnum-p (p)
(and (si::fixnump p) (not (minusp (the fixnum p)))))
(and (si::fixnump p) (not (minusp (truly-the fixnum p)))))
(defun non-positive-fixnum-p (p)
(and (si::fixnump p) (not (plusp (the fixnum p)))))
(and (si::fixnump p) (not (plusp (truly-the fixnum p)))))
(defun array-index-p (p)
(and (si::fixnump p)
(<= 0 (the fixnum p) array-dimension-limit)))
(<= 0 (truly-the fixnum p) array-dimension-limit)))
;;;
;;; Integers
......@@ -106,16 +106,16 @@
'(integer 1 *))
(defun negative-integer-p (p)
(and (integerp p) (minusp (the integer p))))
(and (integerp p) (minusp (truly-the integer p))))
(defun positive-integer-p (p)
(and (integerp p) (plusp (the integer p))))
(and (integerp p) (plusp (truly-the integer p))))
(defun non-negative-integer-p (p)
(and (integerp p) (not (minusp (the integer p)))))
(and (integerp p) (not (minusp (truly-the integer p)))))
(defun non-positive-integer-p (p)
(and (integerp p) (not (plusp (the integer p)))))
(and (integerp p) (not (plusp (truly-the integer p)))))
;;;
;;; Rationals
......@@ -134,16 +134,16 @@
'(rational (0) *))
(defun negative-rational-p (p)
(and (rationalp p) (minusp (the rational p))))
(and (rationalp p) (minusp (truly-the rational p))))
(defun positive-rational-p (p)
(and (rationalp p) (plusp (the rational p))))
(and (rationalp p) (plusp (truly-the rational p))))
(defun non-negative-rational-p (p)
(and (rationalp p) (not (minusp (the rational p)))))
(and (rationalp p) (not (minusp (truly-the rational p)))))
(defun non-positive-rational-p (p)
(and (rationalp p) (not (plusp (the rational p)))))
(and (rationalp p) (not (plusp (truly-the rational p)))))
;;;
;;; Ratios
......@@ -193,16 +193,16 @@
'(real (0) *))
(defun negative-real-p (p)
(and (realp p) (minusp (the real p))))
(and (realp p) (minusp (truly-the real p))))
(defun positive-real-p (p)
(and (realp p) (plusp (the real p))))
(and (realp p) (plusp (truly-the real p))))
(defun non-negative-real-p (p)
(and (realp p) (not (minusp (the real p)))))
(and (realp p) (not (minusp (truly-the real p)))))
(defun non-positive-real-p (p)
(and (realp p) (not (plusp (the real p)))))
(and (realp p) (not (plusp (truly-the real p)))))
;;;
;;; Floats
......@@ -221,16 +221,16 @@
'(float (0) *))
(defun negative-float-p (p)
(and (floatp p) (minusp (the float p))))
(and (floatp p) (minusp (truly-the float p))))
(defun positive-float-p (p)
(and (floatp p) (plusp (the float p))))
(and (floatp p) (plusp (truly-the float p))))
(defun non-negative-float-p (p)
(and (floatp p) (not (minusp (the float p)))))
(and (floatp p) (not (minusp (truly-the float p)))))
(defun non-positive-float-p (p)
(and (floatp p) (not (plusp (the float p)))))
(and (floatp p) (not (plusp (truly-the float p)))))
;;;
;;; SHORT-FLOAT
......@@ -249,16 +249,16 @@
'(short-float (0S0) *))
(defun negative-short-float-p (p)
(and (short-floatp p) (minusp (the short-float p))))
(and (short-floatp p) (minusp (truly-the short-float p))))
(defun positive-short-float-p (p)
(and (short-floatp p) (plusp (the short-float p))))
(and (short-floatp p) (plusp (truly-the short-float p))))
(defun non-negative-short-float-p (p)
(and (short-floatp p) (not (minusp (the short-float p)))))
(and (short-floatp p) (not (minusp (truly-the short-float p)))))
(defun non-positive-short-float-p (p)
(and (short-floatp p) (not (plusp (the short-float p)))))
(and (short-floatp p) (not (plusp (truly-the short-float p)))))
;;;
;;; SINGLE-FLOAT
......@@ -277,16 +277,16 @@
'(single-float (0F0) *))
(defun negative-single-float-p (p)
(and (single-floatp p) (minusp (the single-float p))))
(and (single-floatp p) (minusp (truly-the single-float p))))
(defun positive-single-float-p (p)
(and (single-floatp p) (plusp (the single-float p))))
(and (single-floatp p) (plusp (truly-the single-float p))))
(defun non-negative-single-float-p (p)
(and (single-floatp p) (not (minusp (the single-float p)))))
(and (single-floatp p) (not (minusp (truly-the single-float p)))))
(defun non-positive-single-float-p (p)
(and (single-floatp p) (not (plusp (the single-float p)))))
(and (single-floatp p) (not (plusp (truly-the single-float p)))))
;;;
;;; DOUBLE-FLOAT
......@@ -305,16 +305,16 @@
'(double-float (0D0) *))
(defun negative-double-float-p (p)
(and (double-floatp p) (minusp (the double-float p))))
(and (double-floatp p) (minusp (truly-the double-float p))))
(defun positive-double-float-p (p)
(and (double-floatp p) (plusp (the double-float p))))
(and (double-floatp p) (plusp (truly-the double-float p))))
(defun non-negative-double-float-p (p)
(and (double-floatp p) (not (minusp (the double-float p)))))
(and (double-floatp p) (not (minusp (truly-the double-float p)))))
(defun non-positive-double-float-p (p)
(and (double-floatp p) (not (plusp (the double-float p)))))
(and (double-floatp p) (not (plusp (truly-the double-float p)))))
;;;
;;; LONG-FLOAT
......@@ -333,13 +333,13 @@
'(long-float (0L0) *))
(defun negative-long-float-p (p)
(and (long-floatp p) (minusp (the long-float p))))
(and (long-floatp p) (minusp (truly-the long-float p))))
(defun positive-long-float-p (p)
(and (long-floatp p) (plusp (the long-float p))))
(and (long-floatp p) (plusp (truly-the long-float p))))
(defun non-negative-long-float-p (p)
(and (long-floatp p) (not (minusp (the long-float p)))))
(and (long-floatp p) (not (minusp (truly-the long-float p)))))
(defun non-positive-long-float-p (p)
(and (long-floatp p) (not (plusp (the long-float p)))))
(and (long-floatp p) (not (plusp (truly-the long-float p)))))
......@@ -92,7 +92,7 @@
(multiple-value-bind (reqs opts rest key-flag keys allow-other-keys auxs)
(si::process-lambda-list vl (if macro 'macro 'destructuring-bind))
(let* ((pointer (gensym))
(cons-pointer `(the cons ,pointer))
(cons-pointer `(truly-the cons ,pointer))
(unsafe-car `(car ,cons-pointer))
(unsafe-cdr `(cdr ,cons-pointer))
(unsafe-pop `(setq ,pointer ,unsafe-cdr))
......@@ -100,7 +100,7 @@
(ppn (+ (length reqs) (first opts)))
all-keywords)
;; In macros, eliminate the name of the macro from the list
(dm-v pointer (if macro `(cdr (the cons ,whole)) whole))
(dm-v pointer (if macro `(cdr (truly-the cons ,whole)) whole))
(dolist (v (cdr reqs))
(dm-v v `(progn
(if (null ,pointer)
......@@ -370,4 +370,4 @@ from the function in which it appears." name))))
(dolist (record (macrolet-functions definitions old-env))
(push (list (first record) 'si::macro (second record))
macros))
(rplacd (the cons old-env) macros)))
(rplacd (truly-the cons old-env) macros)))
......@@ -353,3 +353,9 @@ values of the last FORM. If no FORM is given, returns NIL."
(not (eq (first form) 'quote)))
(list 'quote form)
form))
(defmacro ext:truly-the (&rest args)
`(the ,@args))
(defmacro ext:checked-value (&rest args)
`(the ,@args))
......@@ -371,7 +371,7 @@ constructed.
(defun loop-note-minimax-operation (operation minimax)
(declare (si::c-local))
(pushnew (the symbol operation) (loop-minimax-operations minimax))
(pushnew (truly-the symbol operation) (loop-minimax-operations minimax))
(when (and (cdr (loop-minimax-operations minimax))
(not (loop-minimax-flag-variable minimax)))
(setf (loop-minimax-flag-variable minimax) (gensym "LOOP-MAXMIN-FLAG-")))
......@@ -920,8 +920,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
(let ((fn (car x)) (tem nil) (n 0))
(declare (symbol fn) (fixnum n))
(macrolet ((f (overhead &optional (args nil args-p))
`(the fixnum (+ (the fixnum ,overhead)
(the fixnum (list-size ,(if args-p args '(cdr x))))))))
`(truly-the fixnum (+ (truly-the fixnum ,overhead)
(truly-the fixnum (list-size ,(if args-p args '(cdr x))))))))
(cond ((setq tem (get-sysprop fn 'estimate-code-size))
(typecase tem
(fixnum (f tem))
......@@ -1303,7 +1303,7 @@ collected result will be returned as the value of the LOOP."
(declare (si::c-local))
(cond ((or (null name) (null dtype) (eq dtype t)) nil)
((symbolp name)
(unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*))
(unless (or (eq dtype t) (member (truly-the symbol name) *loop-nodeclare*))
;; Allow redeclaration of a variable. This can be used by
;; the loop constructors to make the type more and more
;; precise as we add keywords
......@@ -1431,7 +1431,7 @@ collected result will be returned as the value of the LOOP."
(loop-disallow-aggregate-booleans))
(unless dtype
(setq dtype (or (loop-optional-type) default-type)))
(let ((cruft (find (the symbol name) *loop-collection-cruft*
(let ((cruft (find (truly-the symbol name) *loop-collection-cruft*
:key #'loop-collector-name)))
(cond ((not cruft)
(when (and name (loop-variable-p name))
......@@ -2078,7 +2078,7 @@ collected result will be returned as the value of the LOOP."
(symbolp sequencev)
sequence-type
(subtypep sequence-type 'vector)
(not (member (the symbol sequencev) *loop-nodeclare*)))
(not (member (truly-the symbol sequencev) *loop-nodeclare*)))
(push `(sys:array-register ,sequencev) *loop-declarations*))
(list* nil nil ; dummy bindings and prologue
(loop-sequencer
......
......@@ -199,7 +199,7 @@ If PACKAGE is non-NIL, then only the specified PACKAGE is searched."
(plusp (length name))
(char= #\. (char name 0)))
(let* ((last-dot-position (or (find-non-dot name) (length name)))
(n-dots (the fixnum last-dot-position))
(n-dots (truly-the fixnum last-dot-position))
(name (subseq name last-dot-position)))
;; relative to our (- n-dots 1)'th parent
(let ((p *package*))
......
......@@ -301,16 +301,16 @@
(entry `(,constructor :posn
(index-posn
(pretty-stream-buffer-fill-pointer
(the pretty-stream ,stream))
(truly-the pretty-stream ,stream))
,stream)
,@args))
(op `(list ,entry))
(head `(pretty-stream-queue-head (the pretty-stream ,stream))))
(head `(pretty-stream-queue-head (truly-the pretty-stream ,stream))))
`(progn
(if ,head
(setf (cdr ,head) ,op)
(setf (pretty-stream-queue-tail (the pretty-stream ,stream)) ,op))
(setf (pretty-stream-queue-head (the pretty-stream ,stream)) ,op)
(setf (pretty-stream-queue-tail (truly-the pretty-stream ,stream)) ,op))
(setf (pretty-stream-queue-head (truly-the pretty-stream ,stream)) ,op)
,entry))))
)
......
......@@ -1406,7 +1406,7 @@ if not possible."
(return-from subtypep (values (subclassp t1 t2) t)))
;; Finally, cached results.
(let* ((cache *subtypep-cache*)
(hash (the (integer 0 255) (logand (hash-eql t1 t2) 255)))
(hash (truly-the (integer 0 255) (logand (hash-eql t1 t2) 255)))
(elt (aref cache hash)))
(when (and elt (eq (caar elt) t1) (eq (cdar elt) t2))
(setf elt (cdr elt))
......
......@@ -52,7 +52,7 @@
(cond ((consp type)
(setq name (first type) args (cdr type)))
((si::instancep type)
(setf name (class-name (the class type)) args nil))
(setf name (class-name (truly-the class type)) args nil))
(t
(setq name type args nil)))
(case name
......@@ -146,7 +146,7 @@ default value of INITIAL-ELEMENT depends on TYPE."
((listp sequence)
(nthcdr aux sequence))
((vectorp sequence)
(and (< start (length (the vector sequence)))
(and (< start (length (truly-the vector sequence)))
start))
(t
(error-not-a-sequence sequence)))))
......@@ -160,26 +160,26 @@ default value of INITIAL-ELEMENT depends on TYPE."
(defun seq-iterator-ref (sequence iterator)
(declare (optimize (safety 0)))
(if (si::fixnump iterator)
(aref (the vector sequence) iterator)
(car (the cons iterator))))
(aref (truly-the vector sequence) iterator)
(car (truly-the cons iterator))))
(defun seq-iterator-set (sequence iterator value)
(declare (optimize (safety 0)))
(if (si::fixnump iterator)
(setf (aref (the vector sequence) iterator) value)
(setf (car (the cons iterator)) value)))
(setf (aref (truly-the vector sequence) iterator) value)
(setf (car (truly-the cons iterator)) value)))
(defun seq-iterator-next (sequence iterator)
(declare (optimize (safety 0)))
(cond ((fixnump iterator)
(let ((aux (1+ iterator)))
(declare (fixnum aux))
(and (< aux (length (the vector sequence)))
(and (< aux (length (truly-the vector sequence)))
aux)))
((atom iterator)
(error-not-a-sequence iterator))
(t
(setf iterator (cdr (the cons iterator)))
(setf iterator (cdr (truly-the cons iterator)))
(unless (listp iterator)
(error-not-a-sequence iterator))
iterator)))
......@@ -226,7 +226,7 @@ default value of INITIAL-ELEMENT depends on TYPE."
(let* ((final-length (if (eq length '*) (length object) length)))
(setf output (make-vector elt-type final-length nil nil nil 0))
(do ((i (make-seq-iterator object) (seq-iterator-next output i))
(j 0 (the index (1+ j))))
(j 0 (truly-the index (1+ j))))
((= j final-length)
(setf object output))
(declare (index j))
......
This diff is collapsed.
......@@ -325,7 +325,7 @@ Does not check if the third gang is a single-element list."
(optimize (speed 3) (safety 0)))
(when (and (consp place)
(consp store-form)
(= (length place) (the fixnum (1- (length store-form)))))
(= (length place) (truly-the fixnum (1- (length store-form)))))
(let ((function (pop store-form))
(output '())
v)
......@@ -335,8 +335,8 @@ Does not check if the third gang is a single-element list."
(nreverse (cons newvalue output)))))
(unless (consp store-form)
(return nil))
(setq v (car (the cons store-form))
store-form (cdr (the cons store-form)))
(setq v (car (truly-the cons store-form))
store-form (cdr (truly-the cons store-form)))
(unless (or (eq v i) (eq v (pop vars)))
(return nil))
(push i output)))))
......@@ -670,7 +670,7 @@ Returns the car of the old value in PLACE."
(append vals (list access-form)))
(declare (:read-only ,@vars)) ; Beppe
(prog1 (car ,store-var)
(setq ,store-var (cdr (the list ,store-var)))
(setq ,store-var (cdr (truly-the list ,store-var)))
,store-form)))))
(define-setf-expander values (&rest values &environment env)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment