Changeset 11521
 Timestamp:
 01/02/09 15:23:25 (12 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/compilerpass2.lisp
r11520 r11521 6109 6109 (list 'INTEGER 0 '*)) 6110 6110 6111 (defmacro whenargsinteger (args typenames decls &body body) 6112 "Checks types of the args provided, if all args are 6113 integer, splits them into high/low bytes and invokes the body. 6114 6115 args contains the arguments for which the type check is done. 6116 typenames contains names of variables to which the type, low byte 6117 and high byte of the provided arg is stored, to be used in 6118 the body. 6119 decls contains declarations used in the body, similar to let. 6120 body is the body to invoke. " 6121 (labels ((buildletwhen (body args typenames) 6122 (when args 6123 (let ((type (third typenames)) 6124 (low (second typenames)) 6125 (high (first typenames))) 6126 (setf body 6127 `(let ((,type (derivecompilertype ,(first args)))) 6128 (when (integertypep ,type) 6129 (let ((,low (integertypelow ,type)) 6130 (,high (integertypehigh ,type))) 6131 ,body))))) 6132 (let ((tmpbody 6133 (buildletwhen body (cdr args) (cdddr typenames)))) 6134 (if tmpbody 6135 tmpbody 6136 body))))) 6137 (buildletwhen 6138 `(let (,@decls) ,@body) 6139 (reverse args) (reverse typenames)))) 6140 6111 6141 (defknown derivetypeminus (t) t) 6112 6142 (defun derivetypeminus (form) … … 6115 6145 (case (length args) 6116 6146 (1 6117 (let ((type1 (derivecompilertype (%car args)))) 6118 (when (integertypep type1) 6119 (let* ((low1 (integertypelow type1)) 6120 (high1 (integertypehigh type1)) 6121 (low (and high1 ( high1))) 6122 (high (and low1 ( low1)))) 6123 (setf resulttype (%makeintegertype low high)))))) 6147 (whenargsinteger 6148 ((%car args)) 6149 (type1 low1 high1) 6150 ((low (and high1 ( high1))) 6151 (high (and low1 ( low1)))) 6152 (setf resulttype (%makeintegertype low high)))) 6124 6153 (2 6125 (let ((type1 (derivecompilertype (%car args)))) 6126 (when (integertypep type1) 6127 (let ((type2 (derivecompilertype (%cadr args)))) 6128 (when (integertypep type2) 6129 ;; Both integer types. 6130 (let* ((low1 (integertypelow type1)) 6131 (high1 (integertypehigh type1)) 6132 (low2 (integertypelow type2)) 6133 (high2 (integertypehigh type2)) 6134 (low (and low1 high2 ( low1 high2))) 6135 (high (and high1 low2 ( high1 low2)))) 6136 (setf resulttype (%makeintegertype low high))))))))) 6154 (whenargsinteger 6155 ((%car args) (%cadr args)) 6156 (type1 low1 high1 type2 low2 high2) 6157 ((low (and low1 high2 ( low1 high2))) 6158 (high (and high1 low2 ( high1 low2)))) 6159 (setf resulttype (%makeintegertype low high))))) 6137 6160 resulttype)) 6138 6161 … … 6142 6165 (resulttype t)) 6143 6166 (when (= (length args) 2) 6144 (let ((type1 (derivecompilertype (%car args)))) 6145 (when (integertypep type1) 6146 (let ((type2 (derivecompilertype (%cadr args)))) 6147 (when (integertypep type2) 6148 ;; Both integer types. 6149 (let* ((low1 (integertypelow type1)) 6150 (high1 (integertypehigh type1)) 6151 (low2 (integertypelow type2)) 6152 (high2 (integertypehigh type2)) 6153 (low (and low1 low2 (+ low1 low2))) 6154 (high (and high1 high2 (+ high1 high2)))) 6155 (setf resulttype (%makeintegertype low high)))))))) 6167 (whenargsinteger 6168 ((%car args) (%cadr args)) 6169 (type1 low1 high1 type2 low2 high2) 6170 ((low (and low1 low2 (+ low1 low2))) 6171 (high (and high1 high2 (+ high1 high2)))) 6172 (setf resulttype (%makeintegertype low high)))) 6156 6173 resulttype)) 6157 6174 … … 6165 6182 (let ((n (* arg1 arg2))) 6166 6183 (returnfrom derivetypetimes (%makeintegertype n n)))) 6167 (let ((type1 (derivecompilertype arg1))) 6168 (when (integertypep type1) 6169 (let ((type2 (derivecompilertype arg2))) 6170 (when (integertypep type2) 6171 ;; Both integer types. 6172 (let ((low1 (integertypelow type1)) 6173 (high1 (integertypehigh type1)) 6174 (low2 (integertypelow type2)) 6175 (high2 (integertypehigh type2)) 6176 (low nil) 6177 (high nil)) 6178 (cond ((not (and low1 low2)) 6179 ;; Nothing to do. 6180 ) 6181 ((or (minusp low1) (minusp low2)) 6182 (when (and high1 high2) 6183 (let ((max (* (max (abs low1) (abs high1)) 6184 (max (abs low2) (abs high2))))) 6185 (setf low ( max) 6186 high max)))) 6187 (t 6188 (setf low (* low1 low2)) 6189 (when (and high1 high2) 6190 (setf high (* high1 high2))))) 6191 (setf resulttype (%makeintegertype low high))))))))) 6192 resulttype)) 6184 (whenargsinteger 6185 (arg1 arg2) 6186 (type1 low1 high1 type2 low2 high2) 6187 ((low nil) 6188 (high nil)) 6189 (cond ((not (and low1 low2)) 6190 ;; Nothing to do. 6191 ) 6192 ((or (minusp low1) (minusp low2)) 6193 (when (and high1 high2) 6194 (let ((max (* (max (abs low1) (abs high1)) 6195 (max (abs low2) (abs high2))))) 6196 (setf low ( max) 6197 high max)))) 6198 (t 6199 (setf low (* low1 low2)) 6200 (when (and high1 high2) 6201 (setf high (* high1 high2))))) 6202 (setf resulttype (%makeintegertype low high))))) 6203 resulttype)) 6193 6204 6194 6205 (declaim (ftype (function (t) t) derivetypemax)) … … 6203 6214 (resulttype t)) 6204 6215 (when (= (length form) 3) 6205 (let* ((type1 (derivecompilertype (%car args)))) 6206 (when (integertypep type1) 6207 (let ((type2 (derivecompilertype (%cadr args)))) 6208 (when (integertypep type2) 6209 ;; Both integer types. 6210 (let ((low1 (integertypelow type1)) 6211 (high1 (integertypehigh type1)) 6212 (low2 (integertypelow type2)) 6213 (high2 (integertypehigh type2)) 6214 low high) 6215 (setf low (if (and low1 low2) 6216 (min low1 low2) 6217 nil) 6218 high (if (and high1 high2) 6219 (min high1 high2) 6220 nil)) 6221 (setf resulttype (%makeintegertype low high)))))))) 6216 (whenargsinteger 6217 ((%car args) (%cadr args)) 6218 (type1 low1 high1 type2 low2 high2) 6219 (low high) 6220 (setf low (if (and low1 low2) 6221 (min low1 low2) 6222 nil) 6223 high (if (and high1 high2) 6224 (min high1 high2) 6225 nil)) 6226 (setf resulttype (%makeintegertype low high)))) 6222 6227 resulttype)) 6223 6228 … … 6235 6240 (arg1 (first args)) 6236 6241 (arg2 (second args)) 6237 (type1 (derivecompilertype arg1))6238 (type2 (derivecompilertype arg2))6239 6242 (resulttype 'INTEGER)) 6240 (when (and (integertypep type1) (integertypep type2)) 6241 (let ((low1 (integertypelow type1)) 6242 (high1 (integertypehigh type1)) 6243 (low2 (integertypelow type2)) 6244 (high2 (integertypehigh type2))) 6245 (when (and low1 high1 low2 high2) 6246 (cond ((fixnumconstantvalue type2) 6247 (setf arg2 (fixnumconstantvalue type2)) 6248 (cond ((<= 64 arg2 64) 6249 (setf resulttype 6250 (list 'INTEGER (ash low1 arg2) (ash high1 arg2)))) 6251 ((minusp arg2) 6252 (setf resulttype 6253 (list 'INTEGER 6254 (if (minusp low1) 1 0) 6255 (if (minusp high1) 1 0)))))) 6256 ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0)) 6257 ;; Everything is nonnegative. 6258 (setf resulttype (list 'INTEGER 6259 (ash low1 low2) 6260 (ash high1 high2)))) 6261 ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0)) 6262 ;; Negative (or zero) second argument. 6263 (setf resulttype (list 'INTEGER 6264 (ash low1 low2) 6265 (ash high1 high2)))))))) 6243 (whenargsinteger 6244 (arg1 arg2) 6245 (type1 low1 high1 type2 low2 high2) 6246 () 6247 (when (and low1 high1 low2 high2) 6248 (cond ((fixnumconstantvalue type2) 6249 (setf arg2 (fixnumconstantvalue type2)) 6250 (cond ((<= 64 arg2 64) 6251 (setf resulttype 6252 (list 'INTEGER (ash low1 arg2) (ash high1 arg2)))) 6253 ((minusp arg2) 6254 (setf resulttype 6255 (list 'INTEGER 6256 (if (minusp low1) 1 0) 6257 (if (minusp high1) 1 0)))))) 6258 ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0)) 6259 ;; Everything is nonnegative. 6260 (setf resulttype (list 'INTEGER 6261 (ash low1 low2) 6262 (ash high1 high2)))) 6263 ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0)) 6264 ;; Negative (or zero) second argument. 6265 (setf resulttype (list 'INTEGER 6266 (ash low1 low2) 6267 (ash high1 high2))))))) 6266 6268 (makecompilertype resulttype))) 6267 6269
Note: See TracChangeset
for help on using the changeset viewer.