Fix init-hook regression

db4
Slava Pestov 2008-02-28 01:20:27 -06:00
parent 13290fcd82
commit 7c24a78281
3 changed files with 20 additions and 20 deletions

View File

@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
tuples continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units
generic.standard vocabs threads threads.private init
kernel.private ;
kernel.private libc ;
IN: debugger
GENERIC: error. ( error -- )
@ -63,20 +63,9 @@ M: string error. print ;
[ global [ "Error in print-error!" print drop ] bind ]
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
[
error-in-thread.
print-error
restarts.
nl
@ -265,6 +254,24 @@ M: no-compilation-unit error.
M: no-vocab summary
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
M: thread error-in-thread ( error thread -- )
initial-thread get-global eq? [

View File

@ -142,7 +142,6 @@ DEFER: copy-tree-to
: copy-tree ( from to -- )
over directory? [
dup make-directories
>r dup directory swap r> [
>r swap first path+ r> copy-tree-to
] 2curry each

8
core/libc/libc.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! Copyright (C) 2007 Slava Pestov
! Copyright (C) 2007 Doug Coleman
! 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
<PRIVATE
@ -25,22 +25,16 @@ PRIVATE>
TUPLE: check-ptr ;
M: check-ptr summary drop "Memory allocation failed" ;
: check-ptr ( c-ptr -- c-ptr )
[ \ check-ptr construct-boa throw ] unless* ;
TUPLE: double-free ;
M: double-free summary drop "Free failed since memory is not allocated" ;
: double-free ( -- * )
\ double-free construct-empty throw ;
TUPLE: realloc-error ptr size ;
M: realloc-error summary drop "Memory reallocation failed" ;
: realloc-error ( alien size -- * )
\ realloc-error construct-boa throw ;