Fix init-hook regression
							parent
							
								
									13290fcd82
								
							
						
					
					
						commit
						7c24a78281
					
				| 
						 | 
					@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
 | 
				
			||||||
tuples continuations continuations.private combinators
 | 
					tuples continuations continuations.private combinators
 | 
				
			||||||
generic.math io.streams.duplex classes compiler.units
 | 
					generic.math io.streams.duplex classes compiler.units
 | 
				
			||||||
generic.standard vocabs threads threads.private init
 | 
					generic.standard vocabs threads threads.private init
 | 
				
			||||||
kernel.private ;
 | 
					kernel.private libc ;
 | 
				
			||||||
IN: debugger
 | 
					IN: debugger
 | 
				
			||||||
 | 
					
 | 
				
			||||||
GENERIC: error. ( error -- )
 | 
					GENERIC: error. ( error -- )
 | 
				
			||||||
| 
						 | 
					@ -63,20 +63,9 @@ M: string error. print ;
 | 
				
			||||||
    [ global [ "Error in print-error!" print drop ] bind ]
 | 
					    [ global [ "Error in print-error!" print drop ] bind ]
 | 
				
			||||||
    recover ;
 | 
					    recover ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: error-in-thread. ( -- )
 | 
					 | 
				
			||||||
    error-thread get-global
 | 
					 | 
				
			||||||
    "Error in thread " write
 | 
					 | 
				
			||||||
    [
 | 
					 | 
				
			||||||
        dup thread-id #
 | 
					 | 
				
			||||||
        " (" % dup thread-name %
 | 
					 | 
				
			||||||
        ", " % dup thread-quot unparse-short % ")" %
 | 
					 | 
				
			||||||
    ] "" make
 | 
					 | 
				
			||||||
    swap write-object ":" print nl ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
SYMBOL: error-hook
 | 
					SYMBOL: error-hook
 | 
				
			||||||
 | 
					
 | 
				
			||||||
[
 | 
					[
 | 
				
			||||||
    error-in-thread.
 | 
					 | 
				
			||||||
    print-error
 | 
					    print-error
 | 
				
			||||||
    restarts.
 | 
					    restarts.
 | 
				
			||||||
    nl
 | 
					    nl
 | 
				
			||||||
| 
						 | 
					@ -265,6 +254,24 @@ M: no-compilation-unit error.
 | 
				
			||||||
M: no-vocab summary
 | 
					M: no-vocab summary
 | 
				
			||||||
    drop "Vocabulary does not exist" ;
 | 
					    drop "Vocabulary does not exist" ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					M: check-ptr summary
 | 
				
			||||||
 | 
					    drop "Memory allocation failed" ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					M: double-free summary
 | 
				
			||||||
 | 
					    drop "Free failed since memory is not allocated" ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					M: realloc-error summary
 | 
				
			||||||
 | 
					    drop "Memory reallocation failed" ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: error-in-thread. ( -- )
 | 
				
			||||||
 | 
					    error-thread get-global
 | 
				
			||||||
 | 
					    "Error in thread " write
 | 
				
			||||||
 | 
					    [
 | 
				
			||||||
 | 
					        dup thread-id #
 | 
				
			||||||
 | 
					        " (" % dup thread-name %
 | 
				
			||||||
 | 
					        ", " % dup thread-quot unparse-short % ")" %
 | 
				
			||||||
 | 
					    ] "" make swap write-object ":" print nl ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
! Hooks
 | 
					! Hooks
 | 
				
			||||||
M: thread error-in-thread ( error thread -- )
 | 
					M: thread error-in-thread ( error thread -- )
 | 
				
			||||||
    initial-thread get-global eq? [
 | 
					    initial-thread get-global eq? [
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -142,7 +142,6 @@ DEFER: copy-tree-to
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: copy-tree ( from to -- )
 | 
					: copy-tree ( from to -- )
 | 
				
			||||||
    over directory? [
 | 
					    over directory? [
 | 
				
			||||||
        dup make-directories
 | 
					 | 
				
			||||||
        >r dup directory swap r> [
 | 
					        >r dup directory swap r> [
 | 
				
			||||||
            >r swap first path+ r> copy-tree-to
 | 
					            >r swap first path+ r> copy-tree-to
 | 
				
			||||||
        ] 2curry each
 | 
					        ] 2curry each
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -2,7 +2,7 @@
 | 
				
			||||||
! Copyright (C) 2007 Slava Pestov
 | 
					! Copyright (C) 2007 Slava Pestov
 | 
				
			||||||
! Copyright (C) 2007 Doug Coleman
 | 
					! Copyright (C) 2007 Doug Coleman
 | 
				
			||||||
! See http://factorcode.org/license.txt for BSD license.
 | 
					! See http://factorcode.org/license.txt for BSD license.
 | 
				
			||||||
USING: alien assocs continuations init inspector kernel namespaces ;
 | 
					USING: alien assocs continuations init kernel namespaces ;
 | 
				
			||||||
IN: libc
 | 
					IN: libc
 | 
				
			||||||
 | 
					
 | 
				
			||||||
<PRIVATE
 | 
					<PRIVATE
 | 
				
			||||||
| 
						 | 
					@ -25,22 +25,16 @@ PRIVATE>
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TUPLE: check-ptr ;
 | 
					TUPLE: check-ptr ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: check-ptr summary drop "Memory allocation failed" ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
: check-ptr ( c-ptr -- c-ptr )
 | 
					: check-ptr ( c-ptr -- c-ptr )
 | 
				
			||||||
    [ \ check-ptr construct-boa throw ] unless* ;
 | 
					    [ \ check-ptr construct-boa throw ] unless* ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TUPLE: double-free ;
 | 
					TUPLE: double-free ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: double-free summary drop "Free failed since memory is not allocated" ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
: double-free ( -- * )
 | 
					: double-free ( -- * )
 | 
				
			||||||
    \ double-free construct-empty throw ;
 | 
					    \ double-free construct-empty throw ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TUPLE: realloc-error ptr size ;
 | 
					TUPLE: realloc-error ptr size ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: realloc-error summary drop "Memory reallocation failed" ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
: realloc-error ( alien size -- * )
 | 
					: realloc-error ( alien size -- * )
 | 
				
			||||||
    \ realloc-error construct-boa throw ;
 | 
					    \ realloc-error construct-boa throw ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue