| 
									
										
										
										
											2009-09-12 23:20:13 -04:00
										 |  |  | ! Copyright (C) 2008, 2009 Slava Pestov. | 
					
						
							| 
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 |  |  | ! See http://factorcode.org/license.txt for BSD license. | 
					
						
							| 
									
										
										
										
											2014-12-13 19:10:21 -05:00
										 |  |  | USING: assocs combinators math math.intervals math.order ;
 | 
					
						
							| 
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 |  |  | IN: compiler.tree.comparisons | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ! Some utilities for working with comparison operations. | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2009-09-12 23:20:13 -04:00
										 |  |  | CONSTANT: comparison-ops { < > <= >= u< u> u<= u>= } | 
					
						
							| 
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2009-02-23 21:27:05 -05:00
										 |  |  | CONSTANT: generic-comparison-ops { before? after? before=? after=? } | 
					
						
							| 
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : assumption ( i1 i2 op -- i3 )
 | 
					
						
							|  |  |  |     { | 
					
						
							| 
									
										
										
										
											2009-09-12 23:20:13 -04:00
										 |  |  |         { \ <   [ assume< ] } | 
					
						
							|  |  |  |         { \ >   [ assume> ] } | 
					
						
							|  |  |  |         { \ <=  [ assume<= ] } | 
					
						
							|  |  |  |         { \ >=  [ assume>= ] } | 
					
						
							|  |  |  |         { \ u<  [ assume< ] } | 
					
						
							|  |  |  |         { \ u>  [ assume> ] } | 
					
						
							|  |  |  |         { \ u<= [ assume<= ] } | 
					
						
							|  |  |  |         { \ u>= [ assume>= ] } | 
					
						
							| 
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 |  |  |     } case ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : interval-comparison ( i1 i2 op -- result )
 | 
					
						
							|  |  |  |     { | 
					
						
							| 
									
										
										
										
											2009-09-12 23:20:13 -04:00
										 |  |  |         { \ <   [ interval< ] } | 
					
						
							|  |  |  |         { \ >   [ interval> ] } | 
					
						
							|  |  |  |         { \ <=  [ interval<= ] } | 
					
						
							|  |  |  |         { \ >=  [ interval>= ] } | 
					
						
							|  |  |  |         { \ u<  [ interval< ] } | 
					
						
							|  |  |  |         { \ u>  [ interval> ] } | 
					
						
							|  |  |  |         { \ u<= [ interval<= ] } | 
					
						
							|  |  |  |         { \ u>= [ interval>= ] } | 
					
						
							| 
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 |  |  |     } case ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : swap-comparison ( op -- op' )
 | 
					
						
							|  |  |  |     { | 
					
						
							|  |  |  |         { < > } | 
					
						
							|  |  |  |         { > < } | 
					
						
							|  |  |  |         { <= >= } | 
					
						
							|  |  |  |         { >= <= } | 
					
						
							| 
									
										
										
										
											2009-09-12 23:20:13 -04:00
										 |  |  |         { u< u> } | 
					
						
							|  |  |  |         { u> u< } | 
					
						
							|  |  |  |         { u<= u>= } | 
					
						
							|  |  |  |         { u>= u<= } | 
					
						
							| 
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 |  |  |     } at ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : negate-comparison ( op -- op' )
 | 
					
						
							|  |  |  |     { | 
					
						
							|  |  |  |         { < >= } | 
					
						
							|  |  |  |         { > <= } | 
					
						
							|  |  |  |         { <= > } | 
					
						
							|  |  |  |         { >= < } | 
					
						
							| 
									
										
										
										
											2009-09-12 23:20:13 -04:00
										 |  |  |         { u< u>= } | 
					
						
							|  |  |  |         { u> u<= } | 
					
						
							|  |  |  |         { u<= u> } | 
					
						
							|  |  |  |         { u>= u< } | 
					
						
							| 
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 |  |  |     } at ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : specific-comparison ( op -- op' )
 | 
					
						
							|  |  |  |     { | 
					
						
							|  |  |  |         { before? < } | 
					
						
							|  |  |  |         { after? > } | 
					
						
							|  |  |  |         { before=? <= } | 
					
						
							|  |  |  |         { after=? >= } | 
					
						
							|  |  |  |     } at ;
 |