steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Aaron Schaefer 2009-04-20 21:01:37 -04:00
parent 5006f11342 be2639c168
commit 76417301b4
75 changed files with 420 additions and 215 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/compiler/tests/redefine16.factor Normal file
View File

@ -0,0 +1,10 @@
IN: compiler.tests.redefine16
USING: eval tools.test definitions words compiler.units
quotations stack-checker ;
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
[ "blah" "compiler.tests.redefine16" lookup 1quotation infer ] must-fail

12
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -18,11 +18,18 @@ IN: compiler.tree.optimizer
SYMBOL: check-optimizer?
: ?check ( nodes -- nodes' )
check-optimizer? get [
compute-def-use
dup check-nodes
] when ;
: optimize-tree ( nodes -- nodes' )
analyze-recursive
normalize
propagate
cleanup
?check
dup run-escape-analysis? [
escape-analysis
unbox-tuples
@ -30,10 +37,7 @@ SYMBOL: check-optimizer?
apply-identities
compute-def-use
remove-dead-code
check-optimizer? get [
compute-def-use
dup check-nodes
] when
?check
compute-def-use
optimize-modular-arithmetic
finalize ;

18
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -3,7 +3,7 @@
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart
words namespaces continuations classes fry combinators.smart hints
compiler.tree
compiler.tree.builder
compiler.tree.recursive
@ -136,12 +136,10 @@ DEFER: (flat-length)
[
[ classes-known? 2 0 ? ]
[
{
[ body-length-bias ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
[ body-length-bias ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
tri
node-count-bias
loop-nesting get 0 or 2 *
] bi*
@ -172,7 +170,7 @@ SYMBOL: history
] if ;
: inline-word ( #call word -- ? )
dup def>> inline-word-def ;
dup specialized-def inline-word-def ;
: inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
@ -181,7 +179,9 @@ SYMBOL: history
{ curry compose } memq? ;
: never-inline-word? ( word -- ? )
[ deferred? ] [ { call execute } memq? ] bi or ;
[ deferred? ]
[ "default" word-prop ]
[ { call execute } memq? ] tri or or ;
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;

10
basis/debugger/debugger.factor
View File

@ -88,8 +88,7 @@ M: string error. print ;
: divide-by-zero-error. ( obj -- )
"Division by zero" print drop ;
: signal-error. ( obj -- )
"Operating system signal " write third . ;
HOOK: signal-error. os ( obj -- )
: array-size-error. ( obj -- )
"Invalid array size: " write dup third .
@ -306,4 +305,9 @@ M: check-mixin-class summary drop "Not a mixin class" ;
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
M: wrong-values summary drop "Quotation called with wrong stack effect" ;
M: wrong-values summary drop "Quotation called with wrong stack effect" ;
{
{ [ os windows? ] [ "debugger.windows" require ] }
{ [ os unix? ] [ "debugger.unix" require ] }
} cond

1
basis/debugger/unix/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

23
basis/debugger/unix/unix.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger io kernel math prettyprint sequences system ;
IN: debugger.unix
CONSTANT: signal-names
{
"SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT"
"SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS"
"SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP"
"SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU"
"SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO"
"SIGUSR1" "SIGUSR2"
}
: signal-name ( n -- str/f ) 1- signal-names ?nth ;
: signal-name. ( n -- )
signal-name [ " (" ")" surround write ] when* ;
M: unix signal-error. ( obj -- )
"Unix signal #" write
third [ pprint ] [ signal-name. ] bi nl ;

1
basis/debugger/windows/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

6
basis/debugger/windows/windows.factor Normal file
View File

@ -0,0 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger io prettyprint sequences system ;
IN: debugger.windows
M: windows signal-error. "Windows exception #" write third .h ;

5
basis/editors/emacs/emacs.factor
View File

@ -11,7 +11,10 @@ M: object default-emacsclient ( -- path ) "emacsclient" ;
: emacsclient ( file line -- )
[
{ [ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
{
[ emacsclient-path get-global ]
[ default-emacsclient dup emacsclient-path set-global ]
} 0|| ,
"--no-wait" ,
number>string "+" prepend ,
,

5
basis/help/handbook/handbook.factor
View File

@ -13,13 +13,13 @@ ARTICLE: "conventions" "Conventions"
{ $heading "Documentation conventions" }
"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article."
$nl
"Every article has links to parent articles at the top. These can be persued if the article is too specific."
"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific."
$nl
"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are."
{ $heading "Vocabulary naming conventions" }
"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")."
$nl
"You should should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
"You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
{ $heading "Word naming conventions" }
"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:"
{ $table
@ -249,6 +249,7 @@ ARTICLE: "handbook-language-reference" "The language"
{ $heading "Abstractions" }
{ $subsection "objects" }
{ $subsection "destructors" }
{ $subsection "parsing-words" }
{ $subsection "macros" }
{ $subsection "fry" }
{ $heading "Program organization" }

2
basis/io/buffers/buffers.factor
View File

@ -22,7 +22,7 @@ M: buffer dispose* ptr>> free ;
swap >>fill 0 >>pos drop ;
: buffer-capacity ( buffer -- n )
[ size>> ] [ fill>> ] bi - ; inline
[ size>> ] [ fill>> ] bi - >fixnum ; inline
: buffer-empty? ( buffer -- ? )
fill>> zero? ; inline

44
basis/io/directories/search/search.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays continuations deques dlists fry
io.directories io.files io.files.info io.pathnames kernel
sequences system vocabs.loader ;
sequences system vocabs.loader locals math namespaces
sorting assocs ;
IN: io.directories.search
<PRIVATE
@ -13,10 +14,10 @@ TUPLE: directory-iterator path bfs queue ;
dup directory-files [ append-path ] with map ;
: push-directory ( path iter -- )
[ qualified-directory ] dip [
[ queue>> ] [ bfs>> ] bi
[ qualified-directory ] dip '[
_ [ queue>> ] [ bfs>> ] bi
[ push-front ] [ push-back ] if
] curry each ;
] each ;
: <directory-iterator> ( path bfs? -- iterator )
<dlist> directory-iterator boa
@ -28,12 +29,11 @@ TUPLE: directory-iterator path bfs queue ;
[ over push-directory next-file ] [ nip ] if
] if ;
: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
over next-file [
over call
[ 2nip ] [ iterate-directory ] if*
:: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
iter next-file [
quot call [ iter quot iterate-directory ] unless*
] [
2drop f
f
] if* ; inline recursive
PRIVATE>
@ -70,4 +70,30 @@ ERROR: file-not-found ;
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
'[ _ _ find-all-files ] map concat ; inline
: with-qualified-directory-files ( path quot -- )
'[
"" directory-files current-directory get
'[ _ prepend-path ] map @
] with-directory ; inline
: with-qualified-directory-entries ( path quot -- )
'[
"" directory-entries current-directory get
'[ [ _ prepend-path ] change-name ] map @
] with-directory ; inline
: directory-size ( path -- n )
0 swap t [ link-info size-on-disk>> + ] each-file ;
: directory-usage ( path -- assoc )
[
[
[ name>> dup ] [ directory? ] bi [
directory-size
] [
link-info size-on-disk>>
] if
] { } map>assoc
] with-qualified-directory-entries sort-values ;
os windows? [ "io.directories.search.windows" require ] when

4
basis/io/files/info/info.factor
View File

@ -5,7 +5,7 @@ vocabs.loader io.files.types ;
IN: io.files.info
! File info
TUPLE: file-info type size permissions created modified
TUPLE: file-info type size size-on-disk permissions created modified
accessed ;
HOOK: file-info os ( path -- info )
@ -25,4 +25,4 @@ HOOK: file-system-info os ( path -- file-system-info )
{
{ [ os unix? ] [ "io.files.info.unix." os name>> append ] }
{ [ os windows? ] [ "io.files.info.windows" ] }
} cond require
} cond require

3
basis/io/files/info/unix/unix.factor
View File

@ -63,6 +63,8 @@ M: unix link-info ( path -- info )
M: unix new-file-info ( -- class ) unix-file-info new ;
CONSTANT: standard-unix-block-size 512
M: unix stat>file-info ( stat -- file-info )
[ new-file-info ] dip
{
@ -80,6 +82,7 @@ M: unix stat>file-info ( stat -- file-info )
[ stat-st_rdev >>rdev ]
[ stat-st_blocks >>blocks ]
[ stat-st_blksize >>blocksize ]
[ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
} cleave ;
: n>file-type ( n -- type )

28
basis/io/files/info/windows/windows.factor
View File

@ -5,11 +5,33 @@ io.files.windows io.files.windows.nt kernel windows.kernel32
windows.time windows accessors alien.c-types combinators
generalizations system alien.strings io.encodings.utf16n
sequences splitting windows.errors fry continuations destructors
calendar ascii combinators.short-circuit ;
calendar ascii combinators.short-circuit locals ;
IN: io.files.info.windows
:: round-up-to ( n multiple -- n' )
n multiple rem dup 0 = [
drop n
] [
multiple swap - n +
] if ;
TUPLE: windows-file-info < file-info attributes ;
: get-compressed-file-size ( path -- n )
"DWORD" <c-object> [ GetCompressedFileSize ] keep
over INVALID_FILE_SIZE = [
win32-error-string throw
] [
*uint >64bit
] if ;
: set-windows-size-on-disk ( file-info path -- file-info )
over attributes>> +compressed+ swap member? [
get-compressed-file-size
] [
drop dup size>> 4096 round-up-to
] if >>size-on-disk ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
{
@ -79,7 +101,9 @@ TUPLE: windows-file-info < file-info attributes ;
] if ;
M: windows file-info ( path -- info )
normalize-path get-file-information-stat ;
normalize-path
[ get-file-information-stat ]
[ set-windows-size-on-disk ] bi ;
M: windows link-info ( path -- info )
file-info ;

2
basis/io/files/unique/unique-tests.factor
View File

@ -5,7 +5,7 @@ IN: io.files.unique.tests
[ 123 ] [
"core" ".test" [
[ [ 123 CHAR: a <repetition> ] dip ascii set-file-contents ]
[ [ 123 CHAR: a <string> ] dip ascii set-file-contents ]
[ file-info size>> ] bi
] cleanup-unique-file
] unit-test

2
basis/io/ports/ports.factor
View File

@ -189,4 +189,4 @@ HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii }
HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ;
HINTS: encoder-write { object output-port utf8 } { object output-port ascii } ;

2
basis/stack-checker/known-words/known-words.factor
View File

@ -218,6 +218,8 @@ M: object infer-call*
alien-callback
} [ t "special" set-word-prop ] each
M\ quotation call t "no-compile" set-word-prop
M\ word execute t "no-compile" set-word-prop
\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )

3
basis/tools/deploy/shaker/shaker.factor
View File

@ -15,6 +15,7 @@ QUALIFIED: definitions
QUALIFIED: init
QUALIFIED: layouts
QUALIFIED: source-files
QUALIFIED: source-files.errors
QUALIFIED: vocabs
IN: tools.deploy.shaker
@ -264,6 +265,7 @@ IN: tools.deploy.shaker
compiled-crossref
compiled-generic-crossref
compiler-impl
compiler.errors:compiler-errors
definition-observers
definitions:crossref
interactive-vocabs
@ -275,6 +277,7 @@ IN: tools.deploy.shaker
lexer-factory
print-use-hook
root-cache
source-files.errors:error-types
vocabs:dictionary
vocabs:load-vocab-hook
word

16
basis/tools/test/test-tests.factor
View File

@ -1,4 +1,18 @@
IN: tools.test.tests
USING: tools.test ;
USING: tools.test tools.test.private namespaces kernel sequences ;
\ test-all must-infer
: fake-unit-test ( quot -- )
[
"fake" file set
V{ } clone test-failures set
call
test-failures get
] with-scope ; inline
[ 1 ] [
[
[ "OOPS" ] must-fail
] fake-unit-test length
] unit-test

12
basis/tools/test/test.factor
View File

@ -48,17 +48,17 @@ SYMBOL: file
f file get f failure ;
:: (unit-test) ( output input -- error ? )
[ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline
[ { } input with-datastack output assert-sequence= f f ] [ t ] recover ;
: short-effect ( effect -- pair )
[ in>> length ] [ out>> length ] bi 2array ;
:: (must-infer-as) ( effect quot -- error ? )
[ quot infer short-effect effect assert= f f ] [ t ] recover ; inline
[ quot infer short-effect effect assert= f f ] [ t ] recover ;
:: (must-infer) ( word/quot -- error ? )
word/quot dup word? [ '[ _ execute ] ] when :> quot
[ quot infer drop f f ] [ t ] recover ; inline
[ quot infer drop f f ] [ t ] recover ;
TUPLE: did-not-fail ;
CONSTANT: did-not-fail T{ did-not-fail }
@ -66,11 +66,11 @@ CONSTANT: did-not-fail T{ did-not-fail }
M: did-not-fail summary drop "Did not fail" ;
:: (must-fail-with) ( quot pred -- error ? )
[ quot call did-not-fail t ]
[ dup pred call [ drop f f ] [ t ] if ] recover ; inline
[ { } quot with-datastack drop did-not-fail t ]
[ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover ;
:: (must-fail) ( quot -- error ? )
[ quot call did-not-fail t ] [ drop f f ] recover ; inline
[ { } quot with-datastack drop did-not-fail t ] [ drop f f ] recover ;
: experiment-title ( word -- string )
"(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;

10
basis/ui/tools/profiler/profiler-docs.factor
View File

@ -1,10 +1,14 @@
IN: ui.tools.profiler
USING: help.markup help.syntax ui.operations help.tips ;
USING: help.markup help.syntax ui.operations ui.commands help.tips ;
ARTICLE: "ui.tools.profiler" "UI profiler tool"
ARTICLE: "ui.tools.profiler" "UI profiler tool"
"The " { $vocab-link "ui.tools.profiler" } " vocabulary implements a graphical tool for viewing profiling results (see " { $link "profiling" } ")."
$nl
"To use the profiler, enter a piece of code in the listener's input area and press " { $operation com-profile } "." ;
"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
$nl
"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring."
$nl
"Consult " { $link "profiling" } " for details about the profiler itself." ;
TIP: "Press " { $operation com-profile } " to run the code in the input field with profiling enabled (" { $link "ui.tools.profiler" } ")." ;

11
basis/ui/tools/tools-docs.factor
View File

@ -31,17 +31,6 @@ $nl
$nl
"For more about presentation gadgets, see " { $link "ui.gadgets.presentations" } "." ;
ARTICLE: "ui-profiler" "UI profiler"
"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
$nl
"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
$nl
"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring."
$nl
"Consult " { $link "profiling" } " for details about the profiler itself."
{ $command-map profiler-gadget "toolbar" }
"The profiler is an instance of " { $link profiler-gadget } "." ;
ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X"
"On Mac OS X, the Factor UI offers additional features which integrate with this operating system."
$nl

3
basis/windows/kernel32/kernel32.factor
View File

@ -1139,7 +1139,8 @@ FUNCTION: BOOL GetCommState ( HANDLE hFile, LPDCB lpDCB ) ;
! FUNCTION: GetCommTimeouts
! FUNCTION: GetComPlusPackageInstallStatus
! FUNCTION: GetCompressedFileSizeA
! FUNCTION: GetCompressedFileSizeW
FUNCTION: DWORD GetCompressedFileSizeW ( LPCTSTR lpFileName, LPDWORD lpFileSizeHigh ) ;
ALIAS: GetCompressedFileSize GetCompressedFileSizeW
FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ;
ALIAS: GetComputerName GetComputerNameW
FUNCTION: BOOL GetComputerNameExW ( COMPUTER_NAME_FORMAT NameType, LPTSTR lpBuffer, LPDWORD lpnSize ) ;

2
basis/xml/tests/state-parser-tests.factor
View File

@ -2,7 +2,7 @@ USING: tools.test xml.tokenize xml.state io.streams.string kernel io strings asc
IN: xml.test.state
: string-parse ( str quot -- )
[ <string-reader> ] dip with-state ;
[ <string-reader> ] dip with-state ; inline
: take-rest ( -- string )
[ f ] take-until ;

2
basis/xml/tests/xmltest.factor
View File

@ -43,7 +43,7 @@ MACRO: drop-input ( quot -- newquot )
xml-tests [ unit-test ] assoc-each ;
: works? ( result quot -- ? )
[ first ] [ call ] bi* = ;
[ first ] [ call( -- result ) ] bi* = ;
: partition-xml-tests ( -- successes failures )
xml-tests [ first2 works? ] partition ;

12
basis/xml/writer/writer-tests.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml.data xml.writer tools.test fry xml kernel multiline
USING: xml.data xml.writer tools.test fry xml xml.syntax kernel multiline
xml.writer.private io.streams.string xml.traversal sequences
io.encodings.utf8 io.files accessors io.directories ;
io.encodings.utf8 io.files accessors io.directories math math.parser ;
IN: xml.writer.tests
\ write-xml must-infer
@ -66,3 +66,11 @@ CONSTANT: test-file "resource:basis/xml/writer/test.xml"
[ ] [ "<?xml version='1.0' encoding='UTF-16BE'?><x/>" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test
[ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test
[ ] [ test-file delete-file ] unit-test
[ ] [
{ 1 2 3 4 } [
[ number>string ] [ sq number>string ] bi
[XML <tr><td><-></td><td><-></td></tr> XML]
] map [XML <h2>Timings</h2> <table><-></table> XML]
pprint-xml
] unit-test

2
basis/xml/writer/writer.factor
View File

@ -19,7 +19,7 @@ SYMBOL: indentation
: indent-string ( -- string )
xml-pprint? get
[ indentation get indenter get <repetition> concat ]
[ indentation get indenter get <repetition> "" join ]
[ "" ] if ;
: ?indent ( -- )

6
core/combinators/combinators-docs.factor
View File

@ -303,13 +303,7 @@ ARTICLE: "combinators" "Combinators"
{ $subsection "combinators.short-circuit" }
{ $subsection "combinators.smart" }
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
$nl
"The " { $vocab-link "combinators" } " provides some less frequently-used features."
$nl
"A combinator which can help with implementing methods on " { $link hashcode* } ":"
{ $subsection recursive-hashcode }
{ $subsection "combinators-quot" }
"Advanced topics:"
{ $see-also "quotations" } ;
ABOUT: "combinators"

4
core/io/encodings/encodings.factor
View File

@ -130,7 +130,9 @@ M: encoder stream-element-type
M: encoder stream-write1
>encoder< encode-char ;
: encoder-write ( string stream encoding -- )
GENERIC# encoder-write 2 ( string stream encoding -- )
M: string encoder-write
[ encode-char ] 2curry each ;
M: encoder stream-write

14
core/io/files/files-tests.factor
View File

@ -1,7 +1,7 @@
USING: arrays debugger.threads destructors io io.directories
io.encodings.8-bit io.encodings.ascii io.encodings.binary
io.files io.files.private io.files.temp io.files.unique kernel
make math sequences system threads tools.test ;
make math sequences system threads tools.test generic.standard ;
IN: io.files.tests
\ exists? must-infer
@ -144,3 +144,15 @@ USE: debugger.threads
-10 seek-absolute seek-input
] with-file-reader
] must-fail
[
"non-string-error" unique-file ascii [
{ } write
] with-file-writer
] [ no-method? ] must-fail-with
[
"non-byte-array-error" unique-file binary [
"" write
] with-file-writer
] [ no-method? ] must-fail-with

3
core/parser/parser-docs.factor
View File

@ -94,11 +94,10 @@ $nl
"This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "."
{ $subsection "parser-files" }
"The parser can be extended."
{ $subsection "parsing-words" }
{ $subsection "parser-lexer" }
"The parser can be invoked reflectively;"
{ $subsection parse-stream }
{ $see-also "definitions" "definition-checking" } ;
{ $see-also "parsing-words" "definitions" "definition-checking" } ;
ABOUT: "parser"

6
core/quotations/quotations-docs.factor
View File

@ -25,6 +25,12 @@ ARTICLE: "wrappers" "Wrappers"
{ $subsection wrapper }
{ $subsection literalize }
"Wrapper literal syntax is documented in " { $link "syntax-words" } "."
{ $example
"IN: scratchpad"
"DEFER: my-word"
"\\ my-word name>> ."
"\"my-word\""
}
{ $see-also "combinators" } ;
ABOUT: "quotations"

18
core/syntax/syntax-docs.factor
View File

@ -525,11 +525,19 @@ HELP: ((
{ $description "Literal stack effect syntax." }
{ $notes "Useful for meta-programming with " { $link define-declared } "." }
{ $examples
{ $code
{ $example
"USING: compiler.units kernel math prettyprint random words ;"
"IN: scratchpad"
""
"SYMBOL: my-dynamic-word"
"USING: math random words ;"
"3 { [ + ] [ - ] [ * ] [ / ] } random curry"
"(( x -- y )) define-declared"
""
"["
" my-dynamic-word 2 { [ + ] [ * ] } random curry"
" (( x -- y )) define-declared"
"] with-compilation-unit"
""
"2 my-dynamic-word ."
"4"
}
} ;
@ -789,4 +797,4 @@ HELP: execute(
{ $syntax "execute( stack -- effect )" }
{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
{ POSTPONE: call( POSTPONE: execute( } related-words
{ POSTPONE: call( POSTPONE: execute( } related-words

36
core/words/words.factor
View File

@ -68,10 +68,6 @@ M: word crossref?
vocabulary>> >boolean
] if ;
GENERIC: compiled-crossref? ( word -- ? )
M: word compiled-crossref? crossref? ;
GENERIC# (quot-uses) 1 ( obj assoc -- )
M: object (quot-uses) 2drop ;
@ -131,26 +127,38 @@ compiled-generic-crossref [ H{ } clone ] initialize
: inline? ( word -- ? ) "inline" word-prop ; inline
GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
<PRIVATE
SYMBOL: visited
CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" }
: relevant-callers ( word -- seq )
crossref get at keys
[ word? ] filter
[
[ reset-on-redefine [ word-prop ] with any? ]
[ inline? ]
bi or
] filter ;
: (redefined) ( word -- )
dup visited get key? [ drop ] [
[ reset-on-redefine reset-props ]
[ visited get conjoin ]
[
crossref get at keys
[ word? ] filter
[
[ reset-on-redefine [ word-prop ] with any? ]
[ inline? ]
bi or
] filter
[ (redefined) ] each
[ relevant-callers [ (redefined) ] each ]
[ subwords [ (redefined) ] each ]
bi
] tri
] if ;
PRIVATE>
: redefined ( word -- )
[ H{ } clone visited [ (redefined) ] with-variable ]
[ changed-definition ]
@ -199,10 +207,6 @@ M: word reset-word
"writer" "delimiter"
} reset-props ;
GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
: reset-generic ( word -- )
[ subwords forget-all ]
[ reset-word ]

1
extra/couchdb/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

6
extra/fuel/eval/eval.factor
View File

@ -60,11 +60,11 @@ t fuel-eval-res-flag set-global
[ print-error ] recover ;
: (fuel-eval-usings) ( usings -- )
[ "USE: " prepend ] map
(fuel-eval) fuel-forget-error fuel-forget-output ;
[ [ use+ ] curry [ drop ] recover ] each
fuel-forget-error fuel-forget-output ;
: (fuel-eval-in) ( in -- )
[ dup "IN: " prepend 1array (fuel-eval) in set ] when* ;
[ in set ] when* ;
: (fuel-eval-in-context) ( lines in usings -- )
(fuel-begin-eval)

2
extra/jamshred/game/game.factor
View File

@ -29,7 +29,7 @@ TUPLE: jamshred sounds tunnel players running quit ;
: mouse-moved ( x-radians y-radians jamshred -- )
jamshred-player -rot turn-player ;
: units-per-full-roll ( -- n ) 50 ;
CONSTANT: units-per-full-roll 50
: jamshred-roll ( jamshred n -- )
[ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;

15
extra/jamshred/gl/gl.factor
View File

@ -6,18 +6,17 @@ math.functions math.vectors opengl opengl.gl opengl.glu
opengl.demo-support sequences specialized-arrays.float ;
IN: jamshred.gl
: min-vertices ( -- n ) 6 ; inline
: max-vertices ( -- n ) 32 ; inline
CONSTANT: min-vertices 6
CONSTANT: max-vertices 32
: n-vertices ( -- n ) 32 ; inline
CONSTANT: n-vertices 32
! render enough of the tunnel that it looks continuous
: n-segments-ahead ( -- n ) 60 ; inline
: n-segments-behind ( -- n ) 40 ; inline
CONSTANT: n-segments-ahead 60
CONSTANT: n-segments-behind 40
: wall-drawing-offset ( -- n )
#! so that we can't see through the wall, we draw it a bit further away
0.15 ;
! so that we can't see through the wall, we draw it a bit further away
CONSTANT: wall-drawing-offset 0.15
: wall-drawing-radius ( segment -- r )
radius>> wall-drawing-offset + ;

4
extra/jamshred/jamshred.factor
View File

@ -8,8 +8,8 @@ TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
: <jamshred-gadget> ( jamshred -- gadget )
jamshred-gadget new swap >>jamshred ;
: default-width ( -- x ) 800 ;
: default-height ( -- y ) 600 ;
CONSTANT: default-width 800
CONSTANT: default-height 600
M: jamshred-gadget pref-dim*
drop default-width default-height 2array ;

4
extra/jamshred/player/player.factor
View File

@ -12,8 +12,8 @@ TUPLE: player < oint
{ speed float } ;
! speeds are in GL units / second
: default-speed ( -- speed ) 1.0 ;
: max-speed ( -- speed ) 30.0 ;
CONSTANT: default-speed 1.0
CONSTANT: max-speed 30.0
: <player> ( name sounds -- player )
[ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip

12
extra/jamshred/tunnel/tunnel.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ;
USING: accessors arrays colors combinators kernel literals locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ;
IN: jamshred.tunnel
: n-segments ( -- n ) 5000 ; inline
CONSTANT: n-segments 5000
TUPLE: segment < oint number color radius ;
C: <segment> segment
@ -14,8 +14,8 @@ C: <segment> segment
: random-color ( -- color )
{ 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
: tunnel-segment-distance ( -- n ) 0.4 ;
: random-rotation-angle ( -- theta ) pi 20 / ;
CONSTANT: tunnel-segment-distance 0.4
CONSTANT: random-rotation-angle $[ pi 20 / ]
: random-segment ( previous-segment -- segment )
clone dup random-rotation-angle random-turn
@ -27,7 +27,7 @@ C: <segment> segment
[ dup peek random-segment over push ] dip 1- (random-segments)
] [ drop ] if ;
: default-segment-radius ( -- r ) 1 ;
CONSTANT: default-segment-radius 1
: initial-segment ( -- segment )
float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
@ -115,7 +115,7 @@ C: <segment> segment
: wall-normal ( seg oint -- n )
location>> vector-to-centre normalize ;
: distant ( -- n ) 1000 ;
CONSTANT: distant 1000
: max-real ( a b -- c )
#! sometimes collision-coefficient yields complex roots, so we ignore these (hack)

1
extra/mason/report/fake-data/benchmark-error-messages Normal file
View File

@ -0,0 +1 @@
Benchmarks

1
extra/mason/report/fake-data/benchmark-error-vocabs Normal file
View File

@ -0,0 +1 @@
{ "benchmarks" }

1
extra/mason/report/fake-data/benchmark-time Normal file
View File

@ -0,0 +1 @@
1234

1
extra/mason/report/fake-data/benchmarks Normal file
View File

@ -0,0 +1 @@
H{ { "a" 1 } { "b" 2 } }

2
extra/mason/report/fake-data/boot-log Normal file
View File

@ -0,0 +1,2 @@
Boot
Log

1
extra/mason/report/fake-data/boot-time Normal file
View File

@ -0,0 +1 @@
1234

2
extra/mason/report/fake-data/compile-log Normal file
View File

@ -0,0 +1,2 @@
Compile
Log

1
extra/mason/report/fake-data/compiler-error-messages Normal file
View File

@ -0,0 +1 @@
Compiler errors

1
extra/mason/report/fake-data/compiler-errors Normal file
View File

@ -0,0 +1 @@
{ "compiler-errors" }

1
extra/mason/report/fake-data/git-id Normal file
View File

@ -0,0 +1 @@
"deadbeef"

1
extra/mason/report/fake-data/help-lint-errors Normal file
View File

@ -0,0 +1 @@
Help lint

1
extra/mason/report/fake-data/help-lint-time Normal file
View File

@ -0,0 +1 @@
1234

1
extra/mason/report/fake-data/help-lint-vocabs Normal file
View File

@ -0,0 +1 @@
{ "help-lint" }

1
extra/mason/report/fake-data/html-help-time Normal file
View File

@ -0,0 +1 @@
1234

1
extra/mason/report/fake-data/load-everything-errors Normal file
View File

@ -0,0 +1 @@
Load everything

1
extra/mason/report/fake-data/load-everything-vocabs Normal file
View File

@ -0,0 +1 @@
{ "load-everything" }

1
extra/mason/report/fake-data/load-time Normal file
View File

@ -0,0 +1 @@
1234

1
extra/mason/report/fake-data/test-all-errors Normal file
View File

@ -0,0 +1 @@
Test all errors

1
extra/mason/report/fake-data/test-all-vocabs Normal file
View File

@ -0,0 +1 @@
{ "test-all" }

2
extra/mason/report/fake-data/test-log Normal file
View File

@ -0,0 +1,2 @@
Test
Log

1
extra/mason/report/fake-data/test-time Normal file
View File

@ -0,0 +1 @@
1234

28
extra/mason/report/report-tests.factor
View File

@ -1,4 +1,28 @@
IN: mason.report.tests
USING: mason.report tools.test ;
USING: io.files io.directories kernel mason.report mason.common
tools.test xml xml.writer ;
{ 0 0 } [ [ ] with-report ] must-infer-as
{ 0 0 } [ [ ] with-report ] must-infer-as
: verify-report ( -- )
[ t ] [ "report" exists? ] unit-test
[ ] [ "report" file>xml drop ] unit-test
[ ] [ "report" delete-file ] unit-test ;
"resource:extra/mason/report/fake-data/" [
[ ] [
timings-table pprint-xml
] unit-test
[ ] [ successful-report ] unit-test
verify-report
[ status-error ] [ 1234 compile-failed ] unit-test
verify-report
[ status-error ] [ 1235 boot-failed ] unit-test
verify-report
[ status-error ] [ 1236 test-failed ] unit-test
verify-report
] with-directory

18
extra/mason/report/report.factor
View File

@ -3,7 +3,8 @@
USING: benchmark combinators.smart debugger fry io assocs
io.encodings.utf8 io.files io.sockets io.streams.string kernel
locals mason.common mason.config mason.platform math namespaces
prettyprint sequences xml.syntax xml.writer combinators.short-circuit ;
prettyprint sequences xml.syntax xml.writer combinators.short-circuit
literals ;
IN: mason.report
: common-report ( -- xml )
@ -56,15 +57,14 @@ IN: mason.report
: timings-table ( -- xml )
{
boot-time-file
load-time-file
test-time-file
help-lint-time-file
benchmark-time-file
html-help-time-file
$ boot-time-file
$ load-time-file
$ test-time-file
$ help-lint-time-file
$ benchmark-time-file
$ html-help-time-file
} [
execute( -- string )
dup utf8 file-contents milli-seconds>time
dup eval-file milli-seconds>time
[XML <tr><td><-></td><td><-></td></tr> XML]
] map [XML <h2>Timings</h2> <table><-></table> XML] ;

1
extra/morse/authors.txt
View File

@ -1 +1,2 @@
Alex Chapman
Diego Martinelli

10
extra/morse/morse-docs.factor
View File

@ -5,22 +5,22 @@ IN: morse
HELP: ch>morse
{ $values
{ "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
{ "ch" "A character that has a morse code translation" } { "morse" "A string consisting of zero or more dots and dashes" } }
{ $description "If the given character has a morse code translation, then return that translation, otherwise return a ? character." } ;
HELP: morse>ch
{ $values
{ "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
{ $description "If the given string represents a morse code character, then return that character, otherwise return a space character." } ;
HELP: >morse
{ $values
{ "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } }
{ "str" "A string of ASCII characters which can be translated into morse code" } { "newstr" "A string in morse code" } }
{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." }
{ $see-also morse> ch>morse } ;
HELP: morse>
{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } }
{ $values { "morse" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "plain" "The ASCII translation of the given string" } }
{ $description "Translates morse code into ASCII text" }
{ $see-also >morse morse>ch } ;

34
extra/morse/morse-tests.factor
View File

@ -1,13 +1,43 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: arrays morse strings tools.test ;
IN: morse.tests
[ "" ] [ CHAR: \\ ch>morse ] unit-test
[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test
[ "..." ] [ CHAR: s ch>morse ] unit-test
[ CHAR: s ] [ "..." morse>ch ] unit-test
[ f ] [ "..--..--.." morse>ch ] unit-test
[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
[ ".- -... -.-." ] [ "abc" >morse ] unit-test
[ "abc" ] [ ".- -... -.-." morse> ] unit-test
[ "morse code" ] [
[MORSE
-- --- .-. ... . /
-.-. --- -.. .
MORSE] >morse morse> ] unit-test
[ "morse code 123" ] [
[MORSE
__ ___ ._. ... . /
_._. ___ _.. . /
.____ ..___ ...__
MORSE] ] unit-test
[ [MORSE
-- --- .-. ... . /
-.-. --- -.. .
MORSE] ] [
"morse code" >morse morse>
] unit-test
[ "factor rocks!" ] [
[MORSE
..-. .- -.-. - --- .-. /
.-. --- -.-. -.- ... -.-.--
MORSE] ] unit-test
! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
! [ ] [ "Factor rocks!" play-as-morse ] unit-test

100
extra/morse/morse.factor
View File

@ -1,13 +1,20 @@
! Copyright (C) 2007, 2008 Alex Chapman
! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii assocs combinators hashtables kernel lists math
namespaces make openal parser-combinators promises sequences
strings synth synth.buffers unicode.case ;
USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
IN: morse
<PRIVATE
: morse-codes ( -- array )
{
CONSTANT: dot-char CHAR: .
CONSTANT: dash-char CHAR: -
CONSTANT: char-gap-char CHAR: \s
CONSTANT: word-gap-char CHAR: /
CONSTANT: unknown-char CHAR: ?
PRIVATE>
CONSTANT: morse-code-table $[
H{
{ CHAR: a ".-" }
{ CHAR: b "-..." }
{ CHAR: c "-.-." }
@ -63,68 +70,47 @@ IN: morse
{ CHAR: $ "...-..-" }
{ CHAR: @ ".--.-." }
{ CHAR: \s "/" }
} ;
} >biassoc
]
: ch>morse-assoc ( -- assoc )
morse-codes >hashtable ;
: morse>ch-assoc ( -- assoc )
morse-codes [ reverse ] map >hashtable ;
PRIVATE>
: ch>morse ( ch -- str )
ch>lower ch>morse-assoc at* swap "" ? ;
: ch>morse ( ch -- morse )
ch>lower morse-code-table at [ unknown-char ] unless* ;
: morse>ch ( str -- ch )
morse>ch-assoc at* swap f ? ;
: >morse ( str -- str )
[
[ CHAR: \s , ] [ ch>morse % ] interleave
] "" make ;
morse-code-table value-at [ char-gap-char ] unless* ;
<PRIVATE
: word>morse ( str -- morse )
[ ch>morse ] { } map-as " " join ;
: dot-char ( -- ch ) CHAR: . ;
: dash-char ( -- ch ) CHAR: - ;
: char-gap-char ( -- ch ) CHAR: \s ;
: word-gap-char ( -- ch ) CHAR: / ;
: sentence>morse ( str -- morse )
" " split [ word>morse ] map " / " join ;
: trim-blanks ( str -- newstr )
[ blank? ] trim ; inline
: =parser ( obj -- parser )
[ = ] curry satisfy ;
: morse>word ( morse -- str )
" " split [ morse>ch ] "" map-as ;
LAZY: 'dot' ( -- parser )
dot-char =parser ;
: morse>sentence ( morse -- sentence )
"/" split [ trim-blanks morse>word ] map " " join ;
LAZY: 'dash' ( -- parser )
dash-char =parser ;
LAZY: 'char-gap' ( -- parser )
char-gap-char =parser ;
LAZY: 'word-gap' ( -- parser )
word-gap-char =parser ;
LAZY: 'morse-char' ( -- parser )
'dot' 'dash' <|> <+> ;
LAZY: 'morse-word' ( -- parser )
'morse-char' 'char-gap' list-of ;
LAZY: 'morse-words' ( -- parser )
'morse-word' 'word-gap' list-of ;
: replace-underscores ( str -- str' )
[ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
PRIVATE>
: >morse ( str -- newstr )
trim-blanks sentence>morse ;
: morse> ( morse -- plain )
replace-underscores morse>sentence ;
: morse> ( str -- str )
'morse-words' parse car parsed>> [
[
>string morse>ch
] map >string
] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ;
<PRIVATE
SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
: queue ( symbol -- )
@ -135,7 +121,7 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
: letter-gap ( -- ) letter-gap-buffer queue ;
: beep-freq ( -- n ) 880 ;
CONSTANT: beep-freq 880
: <morse-buffer> ( -- buffer )
half-sample-freq <8bit-mono-buffer> ;

10
extra/synth/buffers/buffers.factor
View File

@ -57,11 +57,11 @@ M: 8bit-stereo-buffer buffer-data
M: 16bit-stereo-buffer buffer-data
interleaved-stereo-data 16bit-buffer-data ;
: telephone-sample-freq ( -- n ) 8000 ;
: half-sample-freq ( -- n ) 22050 ;
: cd-sample-freq ( -- n ) 44100 ;
: digital-sample-freq ( -- n ) 48000 ;
: professional-sample-freq ( -- n ) 88200 ;
CONSTANT: telephone-sample-freq 8000
CONSTANT: half-sample-freq 22050
CONSTANT: cd-sample-freq 44100
CONSTANT: digital-sample-freq 48000
CONSTANT: professional-sample-freq 88200
: send-buffer ( buffer -- buffer )
{

2
misc/fuel/fuel-connection.el
View File

@ -164,7 +164,7 @@
(fuel-con--send-string/wait buffer
fuel-con--init-stanza
'fuel-con--establish-connection-cont
60000)
3000000)
conn))
(defun fuel-con--establish-connection-cont (ignore)

6
vm/bignum.c Normal file → Executable file
View File

@ -170,7 +170,7 @@ bignum_divide(bignum_type numerator, bignum_type denominator,
{
if (BIGNUM_ZERO_P (denominator))
{
divide_by_zero_error(NULL);
divide_by_zero_error();
return;
}
if (BIGNUM_ZERO_P (numerator))
@ -242,7 +242,7 @@ bignum_quotient(bignum_type numerator, bignum_type denominator)
{
if (BIGNUM_ZERO_P (denominator))
{
divide_by_zero_error(NULL);
divide_by_zero_error();
return (BIGNUM_OUT_OF_BAND);
}
if (BIGNUM_ZERO_P (numerator))
@ -295,7 +295,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
{
if (BIGNUM_ZERO_P (denominator))
{
divide_by_zero_error(NULL);
divide_by_zero_error();
return (BIGNUM_OUT_OF_BAND);
}
if (BIGNUM_ZERO_P (numerator))

9
vm/errors.c
View File

@ -124,9 +124,9 @@ void signal_error(int signal, F_STACK_FRAME *native_stack)
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
void divide_by_zero_error(F_STACK_FRAME *native_stack)
void divide_by_zero_error(void)
{
general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack);
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
void memory_signal_handler_impl(void)
@ -134,11 +134,6 @@ void memory_signal_handler_impl(void)
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
void divide_by_zero_signal_handler_impl(void)
{
divide_by_zero_error(signal_callstack_top);
}
void misc_signal_handler_impl(void)
{
signal_error(signal_number,signal_callstack_top);

3
vm/errors.h
View File

@ -26,7 +26,7 @@ void primitive_die(void);
void throw_error(CELL error, F_STACK_FRAME *native_stack);
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack);
void divide_by_zero_error(F_STACK_FRAME *native_stack);
void divide_by_zero_error(void);
void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack);
void signal_error(int signal, F_STACK_FRAME *native_stack);
void type_error(CELL type, CELL tagged);
@ -53,7 +53,6 @@ CELL signal_fault_addr;
void *signal_callstack_top;
void memory_signal_handler_impl(void);
void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);
void primitive_unimplemented(void);

8
vm/os-windows-nt.c
View File

@ -23,12 +23,6 @@ long exception_handler(PEXCEPTION_POINTERS pe)
signal_fault_addr = e->ExceptionInformation[1];
c->EIP = (CELL)memory_signal_handler_impl;
}
else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO
|| e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO)
{
signal_number = ERROR_DIVIDE_BY_ZERO;
c->EIP = (CELL)divide_by_zero_signal_handler_impl;
}
/* If the Widcomm bluetooth stack is installed, the BTTray.exe process
injects code into running programs. For some reason this results in
random SEH exceptions with this (undocumented) exception code being
@ -37,7 +31,7 @@ long exception_handler(PEXCEPTION_POINTERS pe)
this exception means. */
else if(e->ExceptionCode != 0x40010006)
{
signal_number = 11;
signal_number = e->ExceptionCode;
c->EIP = (CELL)misc_signal_handler_impl;
}