Changeset 11633
 Timestamp:
 02/06/09 20:51:34 (12 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/compilerpass2.lisp
r11632 r11633 6207 6207 (list 'INTEGER 0 '*)) 6208 6208 6209 (defmacro whenargsinteger (args typenames decls &body body)6210 "Checks types of the args provided, if all args are6211 integer, splits them into high/low bytes and invokes the body.6212 6213 args contains the arguments for which the type check is done.6214 typenames contains names of variables to which the type, low byte6215 and high byte of the provided arg is stored, to be used in6216 the body.6217 decls contains declarations used in the body, similar to let.6218 body is the body to invoke. "6219 (labels ((buildletwhen (body args typenames)6220 (when args6221 (let ((type (third typenames))6222 (low (second typenames))6223 (high (first typenames)))6224 (setf body6225 `(let ((,type (derivecompilertype ,(first args))))6226 (when (integertypep ,type)6227 (let ((,low (integertypelow ,type))6228 (,high (integertypehigh ,type)))6229 ,body)))))6230 (let ((tmpbody6231 (buildletwhen body (cdr args) (cdddr typenames))))6232 (if tmpbody6233 tmpbody6234 body)))))6235 (buildletwhen6236 `(let (,@decls) ,@body)6237 (reverse args) (reverse typenames))))6238 6239 6209 6240 6210 (defmacro defineintboundsderivation (name (low1 high1 low2 high2) … … 6246 6216 (declare (ignorable ,low1 ,high1 ,low2 ,high2)) 6247 6217 ,@body))) 6248 6249 6218 6250 6219 (defun deriveintegertype (op type1 type2) … … 6280 6249 (doublefloat integer doublefloat) 6281 6250 (doublefloat singlefloat doublefloat)) 6251 ((ash) 6252 (integer integer ,#'deriveintegertype)) 6282 6253 ((min max) 6283 6254 (integer integer ,#'deriveintegertype) … … 6386 6357 (declaim (ftype (function (t) t) derivetypemax)) 6387 6358 (defun derivetypemax (form) 6388 (dolist (arg (cdr form) (makecompilertype 'FIXNUM)) 6389 (unless (fixnumtypep (derivecompilertype arg)) 6390 (return t)))) 6359 (let ((op (car form)) 6360 (args (cdr form))) 6361 (flet ((combine (x y) 6362 (derivetypenumericop op x y))) 6363 (reduce #'combine (cdr args) 6364 :initialvalue (car args))))) 6391 6365 6392 6366 (defknown derivetypemin (t) t) 6393 6367 (defun derivetypemin (form) 6394 (let ((args (cdr form)) 6395 (resulttype t)) 6396 (when (= (length form) 3) 6397 (whenargsinteger 6398 ((%car args) (%cadr args)) 6399 (type1 low1 high1 type2 low2 high2) 6400 (low high) 6401 (setf low (if (and low1 low2) 6402 (min low1 low2) 6403 nil) 6404 high (if (and high1 high2) 6405 (min high1 high2) 6406 nil)) 6407 (setf resulttype (%makeintegertype low high)))) 6408 resulttype)) 6368 (let ((op (car form)) 6369 (args (cdr form))) 6370 (flet ((combine (x y) 6371 (derivetypenumericop op x y))) 6372 (reduce #'combine (cdr args) 6373 :initialvalue (car args))))) 6409 6374 6410 6375 ;; readchar &optional inputstream eoferrorp eofvalue recursivep => char … … 6415 6380 t)) 6416 6381 6382 6383 (defineintboundsderivation ash (low1 high1 low2 high2) 6384 (when (and low1 high1 low2 high2) 6385 (cond 6386 ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0)) 6387 ;; Everything is nonnegative. 6388 (values (ash low1 low2) 6389 (unless (<= 64 high2) 6390 (ash high1 high2)))) 6391 ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0)) 6392 ;; Negative (or zero) second argument. 6393 (values (ash low1 low2) 6394 (ash high1 high2)))))) 6395 6417 6396 ;; ash integer count => shiftedinteger 6418 6397 (defknown derivetypeash (t) t) 6419 6398 (defun derivetypeash (form) 6420 (let* ((args (cdr form)) 6421 (arg1 (first args)) 6422 (arg2 (second args)) 6423 (resulttype 'INTEGER)) 6424 (whenargsinteger 6425 (arg1 arg2) 6426 (type1 low1 high1 type2 low2 high2) 6427 () 6428 (when (and low1 high1 low2 high2) 6429 (cond ((fixnumconstantvalue type2) 6430 (setf arg2 (fixnumconstantvalue type2)) 6431 (cond ((<= 64 arg2 64) 6432 (setf resulttype 6433 (list 'INTEGER (ash low1 arg2) (ash high1 arg2)))) 6434 ((minusp arg2) 6435 (setf resulttype 6436 (list 'INTEGER 6437 (if (minusp low1) 1 0) 6438 (if (minusp high1) 1 0)))))) 6439 ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0)) 6440 ;; Everything is nonnegative. 6441 (setf resulttype (list 'INTEGER 6442 (ash low1 low2) 6443 (if (<= 64 high2) 6444 '* (ash high1 high2))))) 6445 ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0)) 6446 ;; Negative (or zero) second argument. 6447 (setf resulttype (list 'INTEGER 6448 (ash low1 low2) 6449 (ash high1 high2))))))) 6450 (makecompilertype resulttype))) 6399 (derivetypenumericop (car form) 6400 (derivecompilertype (cadr form)) 6401 (derivecompilertype (caddr form)))) 6451 6402 6452 6403 (defknown derivetype (t) t)
Note: See TracChangeset
for help on using the changeset viewer.