Changeset 11604
 Timestamp:
 01/30/09 06:16:49 (13 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/compilerpass2.lisp
r11603 r11604 712 712 (unless (or (zerop *safety*) 713 713 (variablespecialp variable) 714 ;### 714 715 (eq (variablerepresentation variable) :int)) 715 716 (let ((declaredtype (variabledeclaredtype variable))) … … 2324 2325 (setf *staticcode* *code*) 2325 2326 (setf (gethash string ht) g)))) 2326 2327 2327 2328 (defknown compileconstant (t t t) t) 2328 2329 (defun compileconstant (form target representation) … … 6261 6262 (reverse args) (reverse typenames)))) 6262 6263 6264 6265 (defmacro defineintboundsderivation (name (low1 high1 low2 high2) 6266 &body body) 6267 "Associates an integerbounds calculation function with a numeric 6268 operator `name', assuming 2 integer arguments." 6269 `(setf (get ',name 'intbounds) 6270 #'(lambda (,low1 ,high1 ,low2 ,high2) 6271 (declare (ignorable ,low1 ,high1 ,low2 ,high2)) 6272 ,@body))) 6273 6274 6275 (defun deriveintegertype (op type1 type2) 6276 "Derives the composed integer type of operation `op' given integer 6277 types `type1' and `type2'." 6278 (let ((low1 (integertypelow type1)) 6279 (high1 (integertypehigh type1)) 6280 (low2 (integertypelow type2)) 6281 (high2 (integertypehigh type2)) 6282 (opfn (get op 'intbounds))) 6283 (assert opfn) 6284 (multiplevaluebind 6285 (low high nonintp) 6286 (funcall opfn low1 high1 low2 high2) 6287 (if nonintp 6288 nonintp 6289 (%makeintegertype low high))))) 6290 6291 (defvar numericoptypederivation 6292 `(((+  * /) 6293 (integer integer ,#'deriveintegertype) 6294 (integer singlefloat singlefloat) 6295 (integer doublefloat doublefloat) 6296 (singlefloat integer singlefloat) 6297 (singlefloat doublefloat doublefloat) 6298 (doublefloat integer doublefloat) 6299 (doublefloat singlefloat doublefloat)) 6300 ((min max) 6301 (integer integer ,#'deriveintegertype) 6302 (integer singlefloat singlefloat) 6303 (integer doublefloat doublefloat) 6304 (singlefloat doublefloat doublefloat) 6305 (doublefloat singlefloat doublefloat))) 6306 "Table used to derive the return type of a numeric operation, 6307 based on the types of the arguments.") 6308 6309 (defun derivetypenumericop (op &rest types) 6310 "Returns the result type of the numeric operation `op' and the types 6311 of the operation arguments given in `types'." 6312 (let ((typestable 6313 (cdr (assoc op numericoptypederivation :test #'member)))) 6314 (assert typestable) 6315 (flet ((match (type1 type2) 6316 (do* ((remainingtypes typestable (cdr remainingtypes))) 6317 ((endp remainingtypes) 6318 ;; when we don't find a matching type, return T 6319 T) 6320 (destructuringbind 6321 (t1 t2 resulttype) 6322 (car remainingtypes) 6323 (when (and (or (subtypep type1 t1) 6324 (compilersubtypep type1 t1)) 6325 (or (subtypep type2 t2) 6326 (compilersubtypep type2 t2))) 6327 (returnfrom match 6328 (if (functionp resulttype) 6329 (funcall resulttype op type1 type2) 6330 resulttype))))))) 6331 (let ((type1 (car types)) 6332 (type2 (cadr types))) 6333 (when (and (eq type1 type2) 6334 (memq type1 '(SINGLEFLOAT DOUBLEFLOAT))) 6335 (returnfrom derivetypenumericop type1)) 6336 (match type1 type2))))) 6337 6338 (defvar zerointegertype (%makeintegertype 0 0) 6339 "Integer type representing the 0 (zero) 6340 value for use with derivetypeminus.") 6341 6342 (defineintboundsderivation  (low1 high1 low2 high2) 6343 (values (and low1 low2 ( low1 low2)) 6344 (and high1 high2 ( high1 high2)))) 6345 6263 6346 (defknown derivetypeminus (t) t) 6264 6347 (defun derivetypeminus (form) … … 6267 6350 (case (length args) 6268 6351 (1 6269 (whenargsinteger 6270 ((%car args)) 6271 (type1 low1 high1) 6272 ((low (and high1 ( high1))) 6273 (high (and low1 ( low1)))) 6274 (setf resulttype (%makeintegertype low high)))) 6352 (setf resulttype 6353 (derivetypenumericop (car form) 6354 zerointegertype 6355 (derivecompilertype (%car args))))) 6275 6356 (2 6276 (whenargsinteger 6277 ((%car args) (%cadr args)) 6278 (type1 low1 high1 type2 low2 high2) 6279 ((low (and low1 high2 ( low1 high2))) 6280 (high (and high1 low2 ( high1 low2)))) 6281 (setf resulttype (%makeintegertype low high))))) 6357 (setf resulttype 6358 (derivetypenumericop (car form) 6359 (derivecompilertype (car args)) 6360 (derivecompilertype (cadr args)))))) 6282 6361 resulttype)) 6362 6363 6364 (defineintboundsderivation + (low1 high1 low2 high2) 6365 (values (and low1 low2 (+ low1 low2)) 6366 (and high1 high2 (+ high1 high2)))) 6283 6367 6284 6368 (defknown derivetypeplus (t) t) … … 6287 6371 (resulttype t)) 6288 6372 (when (= (length args) 2) 6289 (whenargsinteger 6290 ((%car args) (%cadr args)) 6291 (type1 low1 high1 type2 low2 high2) 6292 ((low (and low1 low2 (+ low1 low2))) 6293 (high (and high1 high2 (+ high1 high2)))) 6294 (setf resulttype (%makeintegertype low high)))) 6373 (setf resulttype 6374 (derivetypenumericop (car form) 6375 (derivecompilertype (car args)) 6376 (derivecompilertype (cadr args))))) 6295 6377 resulttype)) 6296 6378 … … 6859 6941 arg2 'stack resultrep) 6860 6942 (emit (case resultrep 6861 (:int 'iadd)6862 (:long 'ladd)6863 (:float 'fadd)6943 (:int 'iadd) 6944 (:long 'ladd) 6945 (:float 'fadd) 6864 6946 (:double 'dadd) 6865 6947 (t … … 6938 7020 arg2 'stack resultrep) 6939 7021 (emit (case resultrep 6940 (:int 'isub)6941 (:long 'lsub)6942 (:float 'fsub)7022 (:int 'isub) 7023 (:long 'lsub) 7024 (:float 'fsub) 6943 7025 (:double 'dsub) 6944 7026 (t
Note: See TracChangeset
for help on using the changeset viewer.