native/sbuf.o native/socket.o native/stack.o \
native/string.o native/types.o native/vector.o \
native/write.o native/word.o native/compiler.o \
- native/ffi.o
+ native/ffi.o native/signal.o
default:
@echo "Run 'make' with one of the following parameters:"
USE: combinators
USE: compiler
USE: errors
+USE: hashtables
USE: lists
USE: math
USE: namespaces
: c-type ( name -- type )
global [
- dup "c-types" get get* dup [
+ dup "c-types" get hash dup [
nip
] [
drop "No such C type: " swap cat2 throw
: (compile) ( word -- )
#! Should be called inside the with-compiler scope.
- intern dup save-xt word-parameter compile-quot RET ;
+ dup save-xt word-parameter compile-quot RET ;
: compile-postponed ( -- )
compile-words get [
DEFER: set-word-plist
IN: unparser
-DEFER: unparse-float
+DEFER: (unparse-float)
IN: image
denominator
fraction>
str>float
- unparse-float
+ (unparse-float)
float>bits
real
imaginary
: usages. ( word -- )
#! List all usages of a word in all vocabularies.
- intern [
- vocabs [ dupd usages-in-vocab. ] each drop
- ] [
- "Not defined" print
- ] ifte* ;
+ vocabs [ dupd usages-in-vocab. ] each drop ;
: vocab-apropos ( substring vocab -- list )
#! Push a list of all words in a vocabulary whose names
word-file ;
: jedit ( word -- )
- intern dup [
- word-line/file dup [
- jedit-line/file
- ] [
- 3drop "Unknown source" print
- ] ifte
+ word-line/file dup [
+ jedit-line/file
] [
- "Not defined" print
+ 3drop "Unknown source" print
] ifte ;
#! Push the current namespace.
namestack* vector-peek ; inline
-: bind ( namespace quot -- )
- #! Execute a quotation with a namespace on the namestack.
- swap namespace-of >n call n> drop ; inline
-
: with-scope ( quot -- )
#! Execute a quotation with a new namespace on the
#! namestack.
#! An object path is a list of strings. Each string is a
#! variable name in the object namespace at that level.
#! Returns f if any of the objects are not set.
- this swap (object-path) ;
+ namespace swap (object-path) ;
: (set-object-path) ( name -- namespace )
dup namespace get* dup [
"/library/platform/jvm/stream.factor" run-resource ! streams
"/library/platform/jvm/files.factor" run-resource ! files
"/library/stdio.factor" run-resource ! stdio
+"/library/extend-stream.factor" run-resource ! streams
"/library/platform/jvm/unparser.factor" run-resource ! unparser
"/library/platform/jvm/parser.factor" run-resource ! parser
"/library/styles.factor" run-resource ! styles
"/library/platform/jvm/stream.factor" run-resource ! streams
"/library/platform/jvm/files.factor" run-resource ! files
"/library/stdio.factor" run-resource ! stdio
+"/library/extend-stream.factor" run-resource ! streams
"/library/platform/jvm/unparser.factor" run-resource ! unparser
"/library/platform/jvm/parser.factor" run-resource ! parser
"/library/styles.factor" run-resource ! styles
!!! Development tools.
"/library/platform/jvm/processes.factor" run-resource ! processes
-"/library/extend-stream.factor" run-resource ! streams
"/library/stdio-binary.factor" run-resource ! stdio
"/library/vocabulary-style.factor" run-resource ! style
"/library/prettyprint.factor" run-resource ! prettyprint
USE: strings
DEFER: namespace
+DEFER: >n
+DEFER: n>
: namestack* ( -- stack )
#! Push the namespace stack.
[ "java.lang.Object" ] "factor.FactorJava" "toNamespace"
jinvoke-static ;
+: bind ( namespace quot -- )
+ #! Execute a quotation with a namespace on the namestack.
+ swap namespace-of >n call n> drop ; inline
+
: has-namespace? ( a -- boolean )
"factor.FactorObject" is ; inline
: see ( word -- )
0 swap
- intern dup worddef
+ dup worddef
[
[ compound-or-compiled? ] [ word-parameter prettyprint-:; ]
[ shuffle? ] [ word-parameter prettyprint-~<<>>~ ]
USE: logic
USE: namespaces
USE: stack
+USE: strings
: worddef? ( obj -- boolean )
"factor.FactorWordDefinition" is ;
+: intern ( "word" -- word )
+ #! Returns the top of the stack if it already been interned.
+ dup string? [ "use" get search ] when ;
+
: worddef ( word -- worddef )
dup worddef? [
intern dup [ [ "def" get ] bind ] when
"/library/platform/native/io-internals.factor"
"/library/platform/native/stream.factor"
"/library/stdio.factor"
+ "/library/extend-stream.factor"
"/library/platform/native/words.factor"
"/library/words.factor"
"/library/platform/native/vocabularies.factor"
"/library/math/arc-trig-hyp.factor"
"/library/math/list-math.factor"
- "/library/extend-stream.factor"
"/library/platform/native/in-thread.factor"
"/library/platform/native/network.factor"
"/library/logging.factor"
"/library/platform/native/io-internals.factor"
"/library/platform/native/stream.factor"
"/library/stdio.factor"
+ "/library/extend-stream.factor"
"/library/platform/native/words.factor"
"/library/words.factor"
"/library/platform/native/vocabularies.factor"
: ffi-error ( obj -- )
"FFI: " write print ;
+: datastack-underflow-error ( obj -- )
+ drop "Datastack underflow" print ;
+
+: datastack-overflow-error ( obj -- )
+ drop "Datastack overflow" print ;
+
+: callstack-underflow-error ( obj -- )
+ drop "Callstack underflow" print ;
+
+: callstack-overflow-error ( obj -- )
+ drop "Callstack overflow" print ;
+
: kernel-error. ( obj n -- str )
{
expired-error
c-string-error
ffi-disabled-error
ffi-error
+ datastack-underflow-error
+ datastack-overflow-error
+ callstack-underflow-error
+ callstack-overflow-error
} vector-nth execute ;
: kernel-error? ( obj -- ? )
IN: kernel
USE: combinators
-USE: errors
-USE: io-internals
USE: lists
-USE: logic
USE: math
-USE: namespaces
USE: stack
-USE: stdio
USE: strings
USE: vectors
USE: words
-USE: unparser
USE: vectors
: cpu ( -- arch )
#! Test if a = c, b = d.
swapd = [ = ] [ 2drop f ] ifte ;
-: clone ( obj -- obj )
- [
- [ vector? ] [ vector-clone ]
- [ sbuf? ] [ sbuf-clone ]
- [ drop t ] [ ( return the object ) ]
- ] cond ;
-
: set-boot ( quot -- )
#! Set the boot quotation.
8 setenv ;
DEFER: namespace
DEFER: >n
+DEFER: n>
: namestack* ( -- ns ) 3 getenv ;
: set-namestack* ( ns -- ) 3 setenv ;
namespace-buckets <hashtable> ;
: get* ( var namespace -- value ) hash ;
-: set* ( value variable namespace -- ) set-hash ;
-: put* swapd set* ;
+: set* ( value variable namespace -- ) set-hash ;
: namestack-search ( var n -- )
#! Internal word for searching the namestack.
#! from the top down.
namestack* vector-length namestack-search ;
-: set ( value variable -- ) namespace set* ;
-: put ( variable value -- ) namespace put* ;
+: set ( value variable -- ) namespace set-hash ;
+: put ( variable value -- ) swap set ;
+
+: bind ( namespace quot -- )
+ #! Execute a quotation with a namespace on the namestack.
+ swap >n call n> drop ; inline
: vars-values ( -- list ) namespace hash>alist ;
-: vars ( -- list ) vars-values [ car ] map ;
-: values ( -- list ) vars-values [ cdr ] map ;
+: vars ( -- list ) namespace hash-keys ;
+: values ( -- list ) namespace hash-values ;
! We don't have bound objects in native Factor.
-: namespace? hashtable? ;
-: namespace-of ;
-: this namespace ;
: has-namespace? hashtable? ;
USE: continuations
USE: io-internals
USE: errors
+USE: hashtables
USE: kernel
USE: logic
USE: stack
: accept ( server -- client )
#! Accept a connection from a server socket.
- "socket" swap get* blocking-accept <client-stream> ;
+ "socket" swap hash blocking-accept <client-stream> ;
: see ( name -- )
#! Show a word definition.
- intern
[
[ compound? ] [ see-compound ]
[ symbol? ] [ see-symbol ]
USE: continuations
USE: io-internals
USE: errors
+USE: hashtables
USE: kernel
USE: logic
USE: stack
#! Copy the contents of the fd-stream 'from' to the
#! fd-stream 'to'. Use fcopy; this word does not close
#! streams.
- "out" swap get* >r "in" swap get* r> blocking-copy ;
+ "out" swap hash >r "in" swap hash r> blocking-copy ;
: fcopy ( from to -- )
#! Copy the contents of the fd-stream 'from' to the
] assoc ;
: num-types ( -- n )
- #! One more than the maximum value from type-of.
+ #! One more than the maximum value from type primitive.
17 ;
integer%
] ifte reverse%> ;
-: >dec ( num -- string )
- #! Convert an integer to its decimal representation.
- 10 >base ;
-
-: >bin ( num -- string )
- #! Convert an integer to its binary representation.
- 2 >base ;
-
-: >oct ( num -- string )
- #! Convert an integer to its octal representation.
- 8 >base ;
-
-: >hex ( num -- string )
- #! Convert an integer to its hexadecimal representation.
- 16 >base ;
+: >dec ( num -- string ) 10 >base ;
+: >bin ( num -- string ) 2 >base ;
+: >oct ( num -- string ) 8 >base ;
+: >hex ( num -- string ) 16 >base ;
DEFER: unparse
#! output.
"." over str-contains? [ ".0" cat2 ] unless ;
+: unparse-float ( float -- str ) (unparse-float) fix-float ;
+
: unparse-unknown ( obj -- str )
<% "#<" %
dup type type-name %
address unparse %
">" % %> ;
+: unparse-t drop "t" ;
+: unparse-f drop "f" ;
+
: unparse ( obj -- str )
- [
- [ t eq? ] [ drop "t" ]
- [ f eq? ] [ drop "f" ]
- [ word? ] [ unparse-word ]
- [ integer? ] [ >dec ]
- [ ratio? ] [ unparse-ratio ]
- [ float? ] [ unparse-float fix-float ]
- [ complex? ] [ unparse-complex ]
- [ string? ] [ unparse-str ]
- [ drop t ] [ unparse-unknown ]
- ] cond ;
+ {
+ >dec
+ unparse-word
+ unparse-unknown
+ unparse-unknown
+ unparse-ratio
+ unparse-complex
+ unparse-f
+ unparse-t
+ unparse-unknown
+ unparse-unknown
+ unparse-str
+ unparse-unknown
+ unparse-unknown
+ >dec
+ unparse-float
+ unparse-unknown
+ unparse-unknown
+ } generic ;
IN: words
USE: combinators
+USE: hashtables
USE: lists
USE: namespaces
USE: stack
: (search) ( name vocab -- word )
- vocab dup [ get* ] [ 2drop f ] ifte ;
+ vocab dup [ hash ] [ 2drop f ] ifte ;
: search ( name list -- word )
#! Search for a word in a list of vocabularies.
#! Create an undefined word without adding to a vocabulary.
<plist> 0 f rot <word> ;
-: word+ ( name vocab word -- )
- swap vocab* put* ;
+: reveal ( word -- )
+ #! Add a new word to its vocabulary.
+ "vocabularies" get [
+ dup word-vocabulary over word-name 2list set-object-path
+ ] bind ;
: create ( name vocab -- word )
#! Create a new word in a vocabulary. If the vocabulary
#! already contains the word, the existing instance is
#! returned.
- 2dup (search) dup [
- nip nip
- ] [
- drop 2dup (create) dup >r word+ r>
- ] ifte ;
+ 2dup (search) [ nip nip ] [ (create) dup reveal ] ifte* ;
swap word-plist assoc ;
: set-word-property ( word pvalue pname -- )
- pick word-plist pick [ set-assoc ] [ remove-assoc nip ] ifte
+ pick word-plist
+ pick [ set-assoc ] [ remove-assoc nip ] ifte
swap set-word-plist ;
-: defined? ( obj -- ? )
- dup word? [ word-primitive 0 = not ] [ drop f ] ifte ;
+: ?word-primitive ( obj -- prim/0 )
+ dup word? [ word-primitive ] [ drop 0 ] ifte ;
-: compound? ( obj -- ? )
- dup word? [ word-primitive 1 = ] [ drop f ] ifte ;
+: defined? ( obj -- ? ) ?word-primitive 0 = not ;
+: compound? ( obj -- ? ) ?word-primitive 1 = ;
+: primitive? ( obj -- ? ) ?word-primitive 2 > ;
+: symbol? ( obj -- ? ) ?word-primitive 2 = ;
-: primitive? ( obj -- ? )
- dup word? [ word-primitive 2 > ] [ drop f ] ifte ;
+: comment?
+ #! Comments are not first-class objects in CFactor.
+ drop f ;
-: symbol? ( obj -- ? )
- dup word? [ word-primitive 2 = ] [ drop f ] ifte ;
-
-! Various features not supported by native Factor.
-: comment? drop f ;
-
-: word ( -- word )
- global [ "last-word" get ] bind ;
-
-: set-word ( word -- )
- global [ "last-word" set ] bind ;
+: word ( -- word ) global [ "last-word" get ] bind ;
+: set-word ( word -- ) global [ "last-word" set ] bind ;
: define-compound ( word def -- )
over set-word-parameter
dup dup set-word-parameter
2 swap set-word-primitive ;
-: stack-effect ( word -- str )
- "stack-effect" word-property ;
-
-: documentation ( word -- str )
- "documentation" word-property ;
+: stack-effect ( word -- str ) "stack-effect" word-property ;
+: documentation ( word -- str ) "documentation" word-property ;
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+IN: streams
+DEFER: <extend-stream>
+
IN: stdio
USE: combinators
USE: errors
USE: stack
USE: streams
-: <stdio-stream> ( stream -- stream )
- #! We disable fclose on stdio so that various tricks like
- #! with-stream can work.
- clone [
- ( string -- )
- [
- namespace fwrite
- "\n" namespace fwrite
- namespace fflush
- ] "fprint" set
-
- [ ] "fclose" set
- ] extend ;
-
: flush ( -- )
"stdio" get fflush ;
1024 <string-output-stream> [
call "stdio" get stream>str
] with-stream ;
+
+: <stdio-stream> ( stream -- stream )
+ #! We disable fclose on stdio so that various tricks like
+ #! with-stream can work.
+ <extend-stream> [
+ ( string -- )
+ [ write "\n" write flush ] "fprint" set
+
+ [ ] "fclose" set
+ ] extend ;
--- /dev/null
+IN: scratchpad
+USE: combinators
+USE: continuations
+USE: math
+USE: test
+
+! This caused the Java Factor to run out of memory
+[ ] [ 100000 [ [ call ] callcc0 ] times ] unit-test
USE: stack
USE: test
-[ 5000000 [ ] times ] time
-[ 5000000 [ drop ] times* ] time
+[ ] [ 5000000 [ ] times ] unit-test
+[ ] [ 5000000 [ drop ] times* ] unit-test
USE: stack
USE: test
-[ 30000 fac drop ] time
+[ 1 ] [ 10000 fac 10000 [ succ / ] times* ] unit-test
USE: stack
USE: test
-[ 35 fib drop ] time
+[ 9227465 ] [ 34 fib ] unit-test
USE: stack
USE: test
-[ [, 100000 [ 0 10000 random-int , ] times ,] num-sort drop ] time
+[ ] [ [, 100000 [ 0 10000 random-int , ] times ,] num-sort drop ] unit-test
[ t ] [ 10 callcc1-test 10 count = ] unit-test
[ t ] [ callcc-namespace-test ] unit-test
-
-! This caused the Java Factor to run out of memory
-[ ] [ 100000 [ [ call ] callcc0 ] times ] unit-test
10 <vector> "x" set
[ -2 "x" get set-vector-length ] [ drop ] catch
-[ "x" get clone drop ] [ drop ] catch
+[ "x" get vector-clone drop ] [ drop ] catch
10 [ [ -1000000 <vector> ] [ drop ] catch ] times
: doc-test ( -- ) ;
-[ t ] [ "doc-test" ] [ intern word-parameter car comment? ] test-word
+[ t ] [ \ doc-test word-parameter car comment? ] unit-test
[ [ 2 1 0 0 ] ] [ [ is ] ] [ balance>list ] test-word
[ t ] [ "java.lang.Integer" ] [ 0 100 random-int swap is ] test-word
[ [ 1 1 0 0 ] ] [ [ system-property ] ] [ balance>list ] test-word
-[ t ] [ "ifte" intern dup worddef word-of-worddef = ] unit-test
+[ t ] [ \ ifte dup worddef word-of-worddef = ] unit-test
[ f ] [ ] [ 10 namespace-tail-call-bug "x" get 0 = ] test-word
! I did a n> in extend and forgot the obvious case
-[ t ] [ "dup" intern dup ] [ [ ] extend = ] test-word
+[ t ] [ \ dup dup ] [ [ ] extend = ] test-word
+
+: test-this-1 ( -- )
+ <namespace> dup [ this = ] bind ;
+
+[ t ] [ test-this-1 ] unit-test
: test-namespace ( -- )
<namespace> dup [ namespace = ] bind ;
-: test-this-1 ( -- )
- <namespace> dup [ this = ] bind ;
-
[ t ] [ test-namespace ] unit-test
-[ t ] [ test-this-1 ] unit-test
! Object paths should not resolve further up in the namestack.
unit-test
[ t ]
-[ this [ ] object-path = ]
+[ namespace [ ] object-path = ]
unit-test
[ t ]
[
- "test-word" intern
+ \ test-word
global [ [ "vocabularies" "test" "test-word" ] object-path ] bind
=
] unit-test
USE: test
USE: words
-[ vocabs [ words [ see ] each ] each ] time
+[ ] [ vocabs [ words [ see ] each ] each ] unit-test
USE: strings
USE: test
-native? [
- [ t ] [ "Foo" str>sbuf "Foo" str>sbuf = ] unit-test
- [ f ] [ "Foo" str>sbuf "Foob" str>sbuf = ] unit-test
- [ f ] [ 34 "Foo" str>sbuf = ] unit-test
-
- [ "Hello" ] [
- 100 <sbuf> "buf" set
- "Hello" "buf" get sbuf-append
- "buf" get clone "buf-clone" set
- "World" "buf-clone" get sbuf-append
- "buf" get sbuf>str
- ] unit-test
+[ t ] [ "Foo" str>sbuf "Foo" str>sbuf = ] unit-test
+[ f ] [ "Foo" str>sbuf "Foob" str>sbuf = ] unit-test
+[ f ] [ 34 "Foo" str>sbuf = ] unit-test
- [ t ] [
- "Hello world" str>sbuf hashcode
- "Hello world" hashcode =
- ] unit-test
-] when
+[ "Hello" ] [
+ 100 <sbuf> "buf" set
+ "Hello" "buf" get sbuf-append
+ "buf" get sbuf-clone "buf-clone" set
+ "World" "buf-clone" get sbuf-append
+ "buf" get sbuf>str
+] unit-test
+
+[ t ] [
+ "Hello world" str>sbuf hashcode
+ "Hello world" hashcode =
+] unit-test
: keep-datastack ( quot -- )
datastack >r call r> set-datastack drop ;
+: time ( code -- )
+ #! Evaluates the given code and prints the time taken to
+ #! execute it.
+ millis >r call millis r> -
+ unparse write " milliseconds" print ;
+
: unit-test ( output input -- )
[
- 2dup print-test
- swap >r >r clear r> call datastack vector>list r>
- = assert
- ] keep-datastack 2drop ;
+ [
+ 2dup print-test
+ swap >r >r clear r> call datastack vector>list r>
+ = assert
+ ] keep-datastack 2drop
+ ] time ;
: unit-test-fails ( quot -- )
#! Assert that the quotation throws an error.
#! Flag for tests that are known not to work.
3drop ;
-: time ( code -- )
- #! Evaluates the given code and prints the time taken to
- #! execute it.
- "Timing " write dup .
- millis >r call millis r> - . ;
-
: test ( name -- )
! Run the given test.
depth pred >r
"Testing " write dup write "..." print
"/library/test/" swap ".factor" cat3 run-resource
"Checking before/after depth..." print
- depth r> = assert
- ;
+ depth r> = assert ;
: all-tests ( -- )
"Running Factor test suite..." print
"vocabularies" get [ f "scratchpad" set ] bind
[
- "crashes"
"lists/cons"
"lists/lists"
"lists/assoc"
"errors"
"hashtables"
"strings"
- "sbuf"
"namespaces/namespaces"
"files"
"format"
] each
native? [
+ "crashes" test
+ "sbuf" test
"threads" test
cpu "x86" = [
] [
test
] each
- ] when ;
+ ] when
+
+ "benchmark/empty-loop" test
+ "benchmark/fac" test
+ "benchmark/fib" test
+ "benchmark/sort" test
+ "benchmark/continuations" test ;
IN: scratchpad
+USE: lists
+USE: math
USE: parser
USE: test
USE: unparser
[ "\e" ]
[ unparse ]
test-word
+
+[ "1.0" ] [ 1.0 unparse ] unit-test
+[ "f" ] [ f unparse ] unit-test
+[ "t" ] [ t unparse ] unit-test
+[ "car" ] [ \ car unparse ] unit-test
+[ "#{ 1/2 2/3 }" ] [ #{ 1/2 2/3 } unparse ] unit-test
+[ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
#! Get a vocabulary.
global [ "vocabularies" get get* ] bind ;
-: <vocab> ( name -- vocab )
- #! Create a vocabulary.
- <namespace> dup >r "vocabularies" get put* r> ;
-
-: vocab* ( name -- vocab )
- #! Get a vocabulary, creating it if it doesn't exist.
- global [
- dup "vocabularies" get get* dup [
- nip
- ] [
- drop <vocab>
- ] ifte
- ] bind ;
-
: words ( vocab -- list )
#! Push a list of all words in a vocabulary.
#! Filter empty slots.
vocab [ values ] bind [ ] subset ;
-: intern ( "word" -- word )
- #! Returns the top of the stack if it already been interned.
- dup string? [ "use" get search ] when ;
-
: init-search-path ( -- )
! For files
"scratchpad" "file-in" set
exit(1);
}
-void fix_stacks(void)
-{
- if(STACK_UNDERFLOW(ds,ds_bot)
- || STACK_OVERFLOW(ds,ds_bot))
- reset_datastack();
- if(STACK_UNDERFLOW(cs,cs_bot)
- || STACK_OVERFLOW(cs,cs_bot))
- reset_callstack();
-}
-
void throw_error(CELL error)
{
- fix_stacks();
-
dpush(error);
/* Execute the 'throw' word */
call(userenv[BREAK_ENV]);
#define ERROR_C_STRING (12<<3)
#define ERROR_FFI_DISABLED (13<<3)
#define ERROR_FFI (14<<3)
+#define ERROR_DATASTACK_UNDERFLOW (15<<3)
+#define ERROR_DATASTACK_OVERFLOW (16<<3)
+#define ERROR_CALLSTACK_UNDERFLOW (17<<3)
+#define ERROR_CALLSTACK_OVERFLOW (18<<3)
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
-void fix_stacks(void);
void throw_error(CELL object);
void general_error(CELL error, CELL tagged);
void type_error(CELL type, CELL tagged);
/* must always be 8 bits */
typedef unsigned char BYTE;
-/* Memory heap size */
+/* Memory areas */
#define DEFAULT_ARENA (64 * 1024 * 1024)
-#define COMPILE_ZONE_SIZE (4 * 1024 * 1024)
-
-#define STACK_SIZE 16384
+#define COMPILE_ZONE_SIZE (64 * 1024 * 1024)
+#define STACK_SIZE (2 * 1024 * 1024)
#include "memory.h"
#include "error.h"
#include "types.h"
#include "word.h"
#include "run.h"
+#include "signal.h"
#include "fixnum.h"
#include "array.h"
#include "s48_bignumint.h"
void primitive_gc(void)
{
- fprintf(stderr,"GC!\n");
gc_in_progress = true;
flip_zones();
void maybe_garbage_collection(void)
{
if(active.here > active.alarm)
- {
- if(active.here > active.limit)
- {
- fprintf(stderr,"Out of memory\n");
- fprintf(stderr,"active.base = %ld\n",active.base);
- fprintf(stderr,"active.here = %ld\n",active.here);
- fprintf(stderr,"active.limit = %ld\n",active.limit);
- fflush(stderr);
- exit(1);
- }
- else
- primitive_gc();
- }
+ primitive_gc();
}
#include "factor.h"
-void signal_handler(int signal, siginfo_t* siginfo, void* uap)
-{
- general_error(ERROR_SIGNAL,tag_fixnum(signal));
-}
-
-/* Called from a signal handler. XXX - is this safe? */
-void call_profiling_step(int signal, siginfo_t* siginfo, void* uap)
-{
- CELL depth = (cs - cs_bot) / CELLS;
- int i;
- CELL obj;
- for(i = profile_depth; i < depth; i++)
- {
- obj = get(cs_bot + i * CELLS);
- if(TAG(obj) == WORD_TYPE)
- untag_word(obj)->call_count++;
- }
-
- executing->call_count++;
-}
-
-void init_signals(void)
-{
- struct sigaction custom_sigaction;
- struct sigaction profiling_sigaction;
- struct sigaction ign_sigaction;
- custom_sigaction.sa_sigaction = signal_handler;
- custom_sigaction.sa_flags = SA_SIGINFO;
- profiling_sigaction.sa_sigaction = call_profiling_step;
- profiling_sigaction.sa_flags = SA_SIGINFO;
- ign_sigaction.sa_handler = SIG_IGN;
- sigaction(SIGABRT,&custom_sigaction,NULL);
- sigaction(SIGFPE,&custom_sigaction,NULL);
- sigaction(SIGBUS,&custom_sigaction,NULL);
- sigaction(SIGSEGV,&custom_sigaction,NULL);
- sigaction(SIGPIPE,&ign_sigaction,NULL);
- sigaction(SIGPROF,&profiling_sigaction,NULL);
-}
-
void clear_environment(void)
{
int i;
range_error(F,e,USER_ENV);
userenv[e] = value;
}
-
-void primitive_call_profiling(void)
-{
- CELL d = dpop();
- if(d == F)
- {
- timerclear(&prof_timer.it_interval);
- timerclear(&prof_timer.it_value);
-
- profile_depth = 0;
- }
- else
- {
- prof_timer.it_interval.tv_sec = 0;
- prof_timer.it_interval.tv_usec = 1000;
- prof_timer.it_value.tv_sec = 0;
- prof_timer.it_value.tv_usec = 1000;
-
- profile_depth = to_fixnum(d);
- }
-
- if(setitimer(ITIMER_PROF,&prof_timer,NULL) < 0)
- io_error(__FUNCTION__);
-}
callframe = quot;
}
-void signal_handler(int signal, siginfo_t* siginfo, void* uap);
-void call_profiling_step(int signal, siginfo_t* siginfo, void* uap);
-void init_signals(void);
void clear_environment(void);
void run(void);
void primitive_ifte(void);
void primitive_getenv(void);
void primitive_setenv(void);
-void primitive_exit(void);
-void primitive_os_env(void);
-void primitive_call_profiling(void);
--- /dev/null
+#include "factor.h"
+
+void signal_handler(int signal, siginfo_t* siginfo, void* uap)
+{
+ general_error(ERROR_SIGNAL,tag_fixnum(signal));
+}
+
+void memory_signal_handler(int signal, siginfo_t* siginfo, void* uap)
+{
+ if(STACK_UNDERFLOW(ds,ds_bot))
+ {
+ reset_datastack();
+ general_error(ERROR_DATASTACK_UNDERFLOW,F);
+ }
+ else if(STACK_OVERFLOW(ds,ds_bot))
+ {
+ reset_datastack();
+ general_error(ERROR_DATASTACK_OVERFLOW,F);
+ }
+ else if(STACK_UNDERFLOW(cs,cs_bot))
+ {
+ reset_callstack();
+ general_error(ERROR_CALLSTACK_UNDERFLOW,F);
+ }
+ else if(STACK_OVERFLOW(cs,cs_bot))
+ {
+ reset_callstack();
+ general_error(ERROR_CALLSTACK_OVERFLOW,F);
+ }
+ else if(active.here > active.limit)
+ {
+ fprintf(stderr,"Out of memory\n");
+ fprintf(stderr,"active.base = %ld\n",active.base);
+ fprintf(stderr,"active.here = %ld\n",active.here);
+ fprintf(stderr,"active.limit = %ld\n",active.limit);
+ fflush(stderr);
+ exit(1);
+ }
+ else
+ general_error(ERROR_SIGNAL,tag_fixnum(signal));
+}
+
+/* Called from a signal handler. XXX - is this safe? */
+void call_profiling_step(int signal, siginfo_t* siginfo, void* uap)
+{
+ CELL depth = (cs - cs_bot) / CELLS;
+ int i;
+ CELL obj;
+ for(i = profile_depth; i < depth; i++)
+ {
+ obj = get(cs_bot + i * CELLS);
+ if(TAG(obj) == WORD_TYPE)
+ untag_word(obj)->call_count++;
+ }
+
+ executing->call_count++;
+}
+
+void init_signals(void)
+{
+ struct sigaction custom_sigaction;
+ struct sigaction profiling_sigaction;
+ struct sigaction memory_sigaction;
+ struct sigaction ign_sigaction;
+ custom_sigaction.sa_sigaction = signal_handler;
+ custom_sigaction.sa_flags = SA_SIGINFO;
+ profiling_sigaction.sa_sigaction = call_profiling_step;
+ profiling_sigaction.sa_flags = SA_SIGINFO;
+ memory_sigaction.sa_sigaction = memory_signal_handler;
+ memory_sigaction.sa_flags = SA_SIGINFO;
+ ign_sigaction.sa_handler = SIG_IGN;
+ sigaction(SIGABRT,&custom_sigaction,NULL);
+ sigaction(SIGFPE,&custom_sigaction,NULL);
+ sigaction(SIGBUS,&memory_sigaction,NULL);
+ sigaction(SIGSEGV,&memory_sigaction,NULL);
+ sigaction(SIGPIPE,&ign_sigaction,NULL);
+ sigaction(SIGPROF,&profiling_sigaction,NULL);
+}
+
+void primitive_call_profiling(void)
+{
+ CELL d = dpop();
+ if(d == F)
+ {
+ timerclear(&prof_timer.it_interval);
+ timerclear(&prof_timer.it_value);
+
+ profile_depth = 0;
+ }
+ else
+ {
+ prof_timer.it_interval.tv_sec = 0;
+ prof_timer.it_interval.tv_usec = 1000;
+ prof_timer.it_value.tv_sec = 0;
+ prof_timer.it_value.tv_usec = 1000;
+
+ profile_depth = to_fixnum(d);
+ }
+
+ if(setitimer(ITIMER_PROF,&prof_timer,NULL) < 0)
+ io_error(__FUNCTION__);
+}
--- /dev/null
+void signal_handler(int signal, siginfo_t* siginfo, void* uap);
+void call_profiling_step(int signal, siginfo_t* siginfo, void* uap);
+void init_signals(void);
+void primitive_call_profiling(void);
projects / factor.git / commitdiff