classes: adding a check-instance for checking type of things.
This will replace a bunch of not-a-thingy errors that we have in a few places. Those should probably go away anyway, in favor of better type propagation or runtime JIT compilation.master
							parent
							
								
									b3582dd323
								
							
						
					
					
						commit
						cd75a7eb4e
					
				| 
						 | 
					@ -140,3 +140,6 @@ GENERIC: generic-predicate? ( a -- b )
 | 
				
			||||||
} [
 | 
					} [
 | 
				
			||||||
    f { fixnum } { } f  make-class-props
 | 
					    f { fixnum } { } f  make-class-props
 | 
				
			||||||
] unit-test
 | 
					] unit-test
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					{ "test" } [ "test" sequence check-instance ] unit-test
 | 
				
			||||||
 | 
					[ "test" fixnum check-instance ] [ not-an-instance? ] must-fail-with
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -220,11 +220,11 @@ GENERIC: update-methods ( class seq -- )
 | 
				
			||||||
    dup class-usages
 | 
					    dup class-usages
 | 
				
			||||||
    [ nip [ update-class ] each ] [ update-methods ] 2bi ;
 | 
					    [ nip [ update-class ] each ] [ update-methods ] 2bi ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: check-inheritance ( subclass superclass -- )
 | 
					: check-inheritance ( subclass superclass -- subclass superclass )
 | 
				
			||||||
    2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ;
 | 
					    2dup superclass-of? [ bad-inheritance ] when ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: define-class ( word superclass members participants metaclass -- )
 | 
					: define-class ( word superclass members participants metaclass -- )
 | 
				
			||||||
    [ 2dup check-inheritance ] 3dip
 | 
					    [ check-inheritance ] 3dip
 | 
				
			||||||
    make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
 | 
					    make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: forget-predicate ( class -- )
 | 
					: forget-predicate ( class -- )
 | 
				
			||||||
| 
						 | 
					@ -255,3 +255,8 @@ M: class metaclass-changed
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: class forget* ( class -- )
 | 
					M: class forget* ( class -- )
 | 
				
			||||||
    [ call-next-method ] [ forget-class ] bi ;
 | 
					    [ call-next-method ] [ forget-class ] bi ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					ERROR: not-an-instance obj class ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: check-instance ( obj class -- obj )
 | 
				
			||||||
 | 
					    [ dupd instance? ] keep [ not-an-instance ] curry unless ; inline
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue