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

various cleanups, better memory signal handler

cvs
Slava Pestov 2004-10-17 23:01:16 +00:00
parent d61d9e3304
commit 00c4b2d09b
48 changed files with 308 additions and 291 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -16,7 +16,7 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \
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:"

3
library/compiler/alien-types.factor
View File

@ -29,6 +29,7 @@ IN: alien
USE: combinators
USE: compiler
USE: errors
USE: hashtables
USE: lists
USE: math
USE: namespaces
@ -53,7 +54,7 @@ USE: words
: 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

2
library/compiler/compiler.factor
View File

@ -211,7 +211,7 @@ SYMBOL: compile-callstack
: (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 [

4
library/cross-compiler.factor
View File

@ -185,7 +185,7 @@ DEFER: word-plist
DEFER: set-word-plist
IN: unparser
DEFER: unparse-float
DEFER: (unparse-float)
IN: image
@ -230,7 +230,7 @@ IN: image
denominator
fraction>
str>float
unparse-float
(unparse-float)
float>bits
real
imaginary

6
library/inspect-vocabularies.factor
View File

@ -64,11 +64,7 @@ USE: unparser
: 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

10
library/jedit/jedit.factor
View File

@ -67,12 +67,8 @@ USE: words
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 ;

6
library/namespaces.factor
View File

@ -65,10 +65,6 @@ USE: vectors
#! 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.
@ -97,7 +93,7 @@ USE: vectors
#! 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 [

1
library/platform/jvm/boot-mini.factor
View File

@ -69,6 +69,7 @@ USE: parser
"/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

2
library/platform/jvm/boot-sumo.factor
View File

@ -69,6 +69,7 @@ USE: parser
"/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
@ -86,7 +87,6 @@ USE: parser
!!! 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

6
library/platform/jvm/namespaces.factor
View File

@ -34,6 +34,8 @@ USE: stack
USE: strings
DEFER: namespace
DEFER: >n
DEFER: n>
: namestack* ( -- stack )
#! Push the namespace stack.
@ -96,6 +98,10 @@ DEFER: namespace
[ "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

2
library/platform/jvm/prettyprint.factor
View File

@ -57,7 +57,7 @@ USE: words
: see ( word -- )
0 swap
intern dup worddef
dup worddef
[
[ compound-or-compiled? ] [ word-parameter prettyprint-:; ]
[ shuffle? ] [ word-parameter prettyprint-~<<>>~ ]

5
library/platform/jvm/words.factor
View File

@ -33,10 +33,15 @@ USE: lists
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

2
library/platform/native/boot-stage2.factor
View File

@ -68,6 +68,7 @@ USE: stdio
"/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"
@ -94,7 +95,6 @@ USE: stdio
"/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"

1
library/platform/native/boot.factor
View File

@ -61,6 +61,7 @@ primitives,
"/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"

16
library/platform/native/debugger.factor
View File

@ -94,6 +94,18 @@ USE: words
: 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
@ -111,6 +123,10 @@ USE: words
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 -- ? )

13
library/platform/native/kernel.factor
View File

@ -32,18 +32,12 @@ DEFER: vector-hashcode
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 )
@ -112,13 +106,6 @@ IN: kernel
#! 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 ;

19
library/platform/native/namespaces.factor
View File

@ -37,6 +37,7 @@ USE: vectors
DEFER: namespace
DEFER: >n
DEFER: n>
: namestack* ( -- ns ) 3 getenv ;
: set-namestack* ( ns -- ) 3 setenv ;
@ -58,8 +59,7 @@ DEFER: >n
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.
@ -78,15 +78,16 @@ DEFER: >n
#! 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? ;

3
library/platform/native/network.factor
View File

@ -30,6 +30,7 @@ USE: combinators
USE: continuations
USE: io-internals
USE: errors
USE: hashtables
USE: kernel
USE: logic
USE: stack
@ -58,4 +59,4 @@ USE: unparser
: accept ( server -- client )
#! Accept a connection from a server socket.
"socket" swap get* blocking-accept <client-stream> ;
"socket" swap hash blocking-accept <client-stream> ;

1
library/platform/native/prettyprint.factor
View File

@ -74,7 +74,6 @@ USE: words
: see ( name -- )
#! Show a word definition.
intern
[
[ compound? ] [ see-compound ]
[ symbol? ] [ see-symbol ]

3
library/platform/native/stream.factor
View File

@ -30,6 +30,7 @@ USE: combinators
USE: continuations
USE: io-internals
USE: errors
USE: hashtables
USE: kernel
USE: logic
USE: stack
@ -84,7 +85,7 @@ USE: namespaces
#! 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

2
library/platform/native/types.factor
View File

@ -72,5 +72,5 @@ IN: kernel
] assoc ;
: num-types ( -- n )
#! One more than the maximum value from type-of.
#! One more than the maximum value from type primitive.
17 ;

54
library/platform/native/unparser.factor
View File

@ -60,21 +60,10 @@ USE: words
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
@ -121,6 +110,8 @@ 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 %
@ -128,15 +119,26 @@ DEFER: unparse
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 ;

16
library/platform/native/vocabularies.factor
View File

@ -27,12 +27,13 @@
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.
@ -53,15 +54,14 @@ USE: stack
#! 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* ;

38
library/platform/native/words.factor
View File

@ -38,29 +38,24 @@ USE: stack
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
@ -70,8 +65,5 @@ USE: stack
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 ;

27
library/stdio.factor
View File

@ -25,6 +25,9 @@
! 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
@ -34,20 +37,6 @@ USE: namespaces
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 ;
@ -93,3 +82,13 @@ USE: streams
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 ;

8
library/test/benchmark/continuations.factor Normal file
View File

@ -0,0 +1,8 @@
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

4
library/test/benchmark/empty-loop.factor
View File

@ -3,5 +3,5 @@ USE: math
USE: stack
USE: test
[ 5000000 [ ] times ] time
[ 5000000 [ drop ] times* ] time
[ ] [ 5000000 [ ] times ] unit-test
[ ] [ 5000000 [ drop ] times* ] unit-test

2
library/test/benchmark/fac.factor
View File

@ -3,4 +3,4 @@ USE: math
USE: stack
USE: test
[ 30000 fac drop ] time
[ 1 ] [ 10000 fac 10000 [ succ / ] times* ] unit-test

2
library/test/benchmark/fib.factor
View File

@ -3,4 +3,4 @@ USE: math
USE: stack
USE: test
[ 35 fib drop ] time
[ 9227465 ] [ 34 fib ] unit-test

2
library/test/benchmark/sort.factor
View File

@ -5,4 +5,4 @@ USE: random
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

3
library/test/continuations.factor
View File

@ -28,6 +28,3 @@ USE: 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

2
library/test/crashes.factor
View File

@ -28,7 +28,7 @@ USE: lists
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

4
library/test/jvm-compiler/miscellaneous.factor
View File

@ -75,7 +75,7 @@ test-word
: 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
@ -90,4 +90,4 @@ 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

7
library/test/namespaces/java.factor
View File

@ -39,4 +39,9 @@ USE: words
[ 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

8
library/test/namespaces/namespaces.factor
View File

@ -10,11 +10,7 @@ USE: words
: 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.
@ -28,12 +24,12 @@ unit-test
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

2
library/test/prettyprint.factor
View File

@ -4,4 +4,4 @@ USE: prettyprint
USE: test
USE: words
[ vocabs [ words [ see ] each ] each ] time
[ ] [ vocabs [ words [ see ] each ] each ] unit-test

32
library/test/sbuf.factor
View File

@ -9,21 +9,19 @@ USE: stack
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

37
library/test/test.factor
View File

@ -28,12 +28,20 @@ USE: unparser
: 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.
@ -47,26 +55,18 @@ USE: unparser
#! 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"
@ -76,7 +76,6 @@ USE: unparser
"errors"
"hashtables"
"strings"
"sbuf"
"namespaces/namespaces"
"files"
"format"
@ -111,6 +110,8 @@ USE: unparser
] each
native? [
"crashes" test
"sbuf" test
"threads" test
cpu "x86" = [
@ -139,4 +140,10 @@ USE: unparser
] [
test
] each
] when ;
] when
"benchmark/empty-loop" test
"benchmark/fac" test
"benchmark/fib" test
"benchmark/sort" test
"benchmark/continuations" test ;

9
library/test/unparser.factor
View File

@ -1,4 +1,6 @@
IN: scratchpad
USE: lists
USE: math
USE: parser
USE: test
USE: unparser
@ -17,3 +19,10 @@ test-word
[ "\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

18
library/vocabularies.factor
View File

@ -41,29 +41,11 @@ USE: strings
#! 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

12
native/error.c
View File

@ -13,20 +13,8 @@ void critical_error(char* msg, CELL tagged)
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]);

5
native/error.h
View File

@ -13,10 +13,13 @@
#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);

8
native/factor.h
View File

@ -49,11 +49,10 @@ typedef unsigned short CHAR;
/* 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"
@ -61,6 +60,7 @@ typedef unsigned char BYTE;
#include "types.h"
#include "word.h"
#include "run.h"
#include "signal.h"
#include "fixnum.h"
#include "array.h"
#include "s48_bignumint.h"

15
native/gc.c
View File

@ -132,7 +132,6 @@ void collect_roots(void)
void primitive_gc(void)
{
fprintf(stderr,"GC!\n");
gc_in_progress = true;
flip_zones();
@ -156,17 +155,5 @@ are also reachable via the GC roots. */
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();
}

63
native/run.c
View File

@ -1,44 +1,5 @@
#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;
@ -132,27 +93,3 @@ void primitive_setenv(void)
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__);
}

6
native/run.h
View File

@ -93,9 +93,6 @@ INLINE void call(CELL quot)
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);
@ -107,6 +104,3 @@ void primitive_call(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);

102
native/signal.c Normal file
View File

@ -0,0 +1,102 @@
#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__);
}

4
native/signal.h Normal file
View File

@ -0,0 +1,4 @@
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);