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

various cleanups, code primitive now shows code space usage, :get and &get, working on inferencer

cvs
Slava Pestov 2004-11-20 21:57:01 +00:00
parent e3e434e649
commit 772ae356ee
35 changed files with 288 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
examples/dejong.factor
View File

@ -5,7 +5,7 @@
!
! Then, enter this at the interpreter prompt:
!
! "contrib/dejong.factor" run-file
! "examples/dejong.factor" run-file
! For details on DeJong attractors, see
! http://www.complexification.net/gallery/machines/peterdejong/

2
examples/mandel.factor
View File

@ -5,7 +5,7 @@
!
! Then, enter this at the interpreter prompt:
!
! "contrib/mandel.factor" run-file
! "examples/mandel.factor" run-file
IN: mandel

2
factor/FactorArray.java
View File

@ -33,7 +33,7 @@ package factor;
* A growable array.
* @author Slava Pestov
*/
public class FactorArray implements FactorExternalizable, PublicCloneable
public class FactorArray implements FactorExternalizable
{
public Object[] array;
public int top;

2
factor/jedit/FactorPlugin.props
View File

@ -47,7 +47,7 @@ factor.completion.colon=: <b>{0}</b>
factor.completion.defer=DEFER: <b>{0}</b>
factor.completion.parsing=PARSING: <b>{0}</b>
factor.completion.symbol=SYMBOL: <b>{0}</b>
factor.completion.stack={0} ({1})
factor.completion.stack={0} ( {1})
# Dialog boxes
factor.status.inserted-use=Inserted {0}

12
factor/jedit/FactorShell.java
View File

@ -220,10 +220,16 @@ public class FactorShell extends Shell
openStream(output);
FactorStream.Packet p;
while((p = stream.nextPacket()) != null)
for(;;)
{
if(p instanceof FactorStream.ReadLinePacket)
FactorStream.Packet p = stream.nextPacket();
if(p == null)
{
/* EOF */
closeStream();
break;
}
else if(p instanceof FactorStream.ReadLinePacket)
{
waitingForInput = true;
break;

11
factor/jedit/FactorSideKickParser.java
View File

@ -110,7 +110,14 @@ public class FactorSideKickParser extends SideKickParser
buffer.readLock();
text = buffer.getText(0,buffer.getLength());
}
finally
{
buffer.readUnlock();
}
try
{
/* of course wrapping a string reader in a buffered
reader is dumb, but the FactorReader uses readLine() */
FactorScanner scanner = new RestartableFactorScanner(
@ -140,10 +147,6 @@ public class FactorSideKickParser extends SideKickParser
0,0,0,e.toString());
Log.log(Log.DEBUG,this,e);
}
finally
{
buffer.readUnlock();
}
return d;
} //}}}

2
factor/jedit/FactorWordRenderer.java
View File

@ -81,7 +81,7 @@ public class FactorWordRenderer extends DefaultListCellRenderer
new Object[] { MiscUtilities.charsToEntities(word.name) });
if(word.stackEffect != null)
{
html += jEdit.getProperty("factor.completion.stack",
html = jEdit.getProperty("factor.completion.stack",
new String[] { html, word.stackEffect });
}

47
factor/jedit/WordPreview.java
View File

@ -73,17 +73,20 @@ public class WordPreview implements ActionListener, CaretListener
//{{{ public void actionPerformed() method
public void actionPerformed(ActionEvent evt)
{
try
{
showPreview();
}
catch(IOException e)
{
throw new RuntimeException(e);
}
} //}}}
//{{{ showPreview() method
private void showPreview()
{
View view = textArea.getView();
SideKickParsedData data = SideKickParsedData.getParsedData(view);
if(data instanceof FactorParsedData)
//{{{ getWordAtCaret() method
private FactorWord getWordAtCaret(FactorParsedData fdata)
throws IOException
{
int line = textArea.getCaretLine();
int caret = textArea.getCaretPosition();
@ -96,7 +99,7 @@ public class WordPreview implements ActionListener, CaretListener
int len = textArea.getLineLength(line);
if(len == 0)
return;
return null;
if(offset == len)
offset--;
@ -108,19 +111,30 @@ public class WordPreview implements ActionListener, CaretListener
for(int i = 0; i < IGNORED_RULESETS.length; i++)
{
if(name.equals(IGNORED_RULESETS[i]))
return;
return null;
}
String word = FactorPlugin.getWordAtCaret(textArea);
if(word == null)
return null;
return FactorPlugin.getExternalInstance()
.searchVocabulary(fdata.use,word);
} //}}}
//{{{ showPreview() method
private void showPreview()
throws IOException
{
View view = textArea.getView();
if(SideKickPlugin.isParsingBuffer(view.getBuffer()))
return;
FactorParsedData fdata = (FactorParsedData)data;
try
SideKickParsedData data = SideKickParsedData.getParsedData(view);
if(data instanceof FactorParsedData)
{
FactorWord w = FactorPlugin.getExternalInstance()
.searchVocabulary(fdata.use,word);
FactorWord w = getWordAtCaret((FactorParsedData)data);
if(w != null)
{
view.getStatus().setMessageAndClear(
@ -128,10 +142,5 @@ public class WordPreview implements ActionListener, CaretListener
w,true));
}
}
catch(IOException e)
{
throw new RuntimeException(e);
}
}
} //}}}
}

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

@ -101,7 +101,7 @@ USE: words
#! Define inline and pointer type for the struct. Pointer
#! type is exactly like void*.
[ "width" set ] "struct-name" get define-c-type
"void*" c-type "struct-name" get "*" cat2 c-types set* ;
"void*" c-type "struct-name" get "*" cat2 c-types set-hash ;
: BEGIN-STRUCT: ( -- offset )
scan "struct-name" set 0 ; parsing

5
library/files.factor
View File

@ -27,6 +27,7 @@
IN: files
USE: combinators
USE: hashtables
USE: lists
USE: logic
USE: namespaces
@ -44,10 +45,10 @@ USE: strings
] ;
: set-mime-types ( assoc -- )
"mime-types" global set* ;
"mime-types" global set-hash ;
: mime-types ( -- assoc )
"mime-types" global get* ;
"mime-types" global hash ;
: file-extension ( filename -- extension )
"." split cdr dup [ last ] when ;

2
library/httpd/resource-responder.factor
View File

@ -51,7 +51,7 @@ USE: strings
] ifte ;
: resource-responder ( filename -- )
java? "resource-path" get or [
"resource-path" get [
serve-resource
] [
drop "404 resource-path not set" httpd-error

9
library/httpd/responder.factor
View File

@ -28,6 +28,7 @@
IN: httpd-responder
USE: combinators
USE: hashtables
USE: httpd
USE: kernel
USE: lists
@ -72,15 +73,15 @@ USE: strings
] extend ;
: get-responder ( name -- responder )
"httpd-responders" get get* [
"404" "httpd-responders" get get*
"httpd-responders" get hash [
"404" "httpd-responders" get hash
] unless* ;
: default-responder ( -- responder )
"default" get-responder ;
: set-default-responder ( name -- )
get-responder "default" "httpd-responders" get set* ;
get-responder "default" "httpd-responders" get set-hash ;
: responder-argument ( argument -- argument )
dup f-or-"" [ drop "default-argument" get ] when ;
@ -121,4 +122,4 @@ USE: strings
: add-responder ( responder -- )
#! Add a responder object to the list.
"responder" over get* "httpd-responders" get set* ;
"responder" over hash "httpd-responders" get set-hash ;

5
library/logging.factor
View File

@ -27,8 +27,9 @@
IN: logging
USE: namespaces
USE: combinators
USE: hashtables
USE: namespaces
USE: stack
USE: streams
USE: strings
@ -43,7 +44,7 @@ USE: unparser
: log-client ( -- )
"client" get [
"Accepted connection from " swap
"client" swap get* cat2 log
"client" swap hash cat2 log
] when* ;
: with-logging ( quot -- )

2
library/math/arithmetic.factor
View File

@ -57,7 +57,7 @@ USE: stack
#! by swapping them.
2dup > [ swap ] when >r dupd max r> min = ;
: sq dup * ; inline
: sq dup * ; inline recursive-infer
: pred 1 - ; inline
: succ 1 + ; inline

7
library/namespaces.factor
View File

@ -27,6 +27,7 @@
IN: namespaces
USE: combinators
USE: hashtables
USE: kernel
USE: lists
USE: logic
@ -55,7 +56,7 @@ USE: vectors
: namespace ( -- namespace )
#! Push the current namespace.
namestack* vector-peek ; inline
namestack car ; inline
: with-scope ( quot -- )
#! Execute a quotation with a new namespace on the
@ -76,7 +77,7 @@ USE: vectors
over get [ drop get ] [ swap >r call dup r> set ] ifte ;
: traverse-path ( name object -- object )
dup has-namespace? [ get* ] [ 2drop f ] ifte ;
dup hashtable? [ hash ] [ 2drop f ] ifte ;
: (object-path) ( object list -- object )
[ uncons >r swap traverse-path r> (object-path) ] when* ;
@ -88,7 +89,7 @@ USE: vectors
namespace swap (object-path) ;
: (set-object-path) ( name -- namespace )
dup namespace get* dup [
dup namespace hash dup [
nip
] [
drop <namespace> tuck put

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

@ -35,7 +35,6 @@ primitives,
"/library/platform/native/stack.factor"
"/library/platform/native/types.factor"
"/library/math/math.factor"
"/library/platform/native/math.factor"
"/library/cons.factor"
"/library/combinators.factor"
"/library/logic.factor"
@ -70,6 +69,7 @@ primitives,
"/library/platform/native/parser.factor"
"/library/platform/native/parse-syntax.factor"
"/library/platform/native/parse-stream.factor"
"/library/platform/native/math.factor"
"/library/platform/native/init.factor"
] [
cross-compile-resource

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

@ -109,9 +109,3 @@ IN: kernel
: set-boot ( quot -- )
#! Set the boot quotation.
8 setenv ;
: java? f ;
: native? t ;
! No compiler...
: inline ;

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

@ -37,26 +37,22 @@ USE: vectors
DEFER: namespace
: namestack* ( -- ns ) 3 getenv ;
: set-namestack* ( ns -- ) 3 setenv ;
: namestack ( -- ns ) 3 getenv ;
: set-namestack ( ns -- ) 3 setenv ;
: >n ( namespace -- n:namespace )
#! Push a namespace on the namespace stack.
namestack* vector-push ; inline
namestack cons set-namestack ; inline
: n> ( n:namespace -- namespace )
#! Pop the top of the namespace stack.
namestack* vector-pop ; inline
: namestack ( -- stack ) namestack* vector-clone ;
: set-namestack ( stack -- ) vector-clone set-namestack* ;
namestack uncons set-namestack ; inline
: global ( -- g ) 4 getenv ;
: set-global ( g -- ) 4 setenv ;
: init-namespaces ( -- )
64 <vector> set-namestack* global >n
global "global" set ;
global >n global "global" set ;
: namespace-buckets 23 ;
@ -64,25 +60,22 @@ DEFER: namespace
#! Create a new namespace.
namespace-buckets <hashtable> ;
: get* ( var namespace -- value ) hash ;
: set* ( value variable namespace -- ) set-hash ;
: namestack-search ( var n -- )
: (get) ( var ns -- value )
#! Internal word for searching the namestack.
dup 0 eq? [
2drop f ( not found )
dup [
2dup car hash* dup [
nip nip cdr ( found )
] [
pred 2dup >r >r namestack* vector-nth hash* dup [
r> drop r> drop ( [ key | value ] -- ) cdr ( found )
] [
drop r> r> namestack-search ( check next entry )
drop cdr (get) ( keep looking )
] ifte
] [
2drop f
] ifte ;
: get ( variable -- value )
#! Push the value of a variable by searching the namestack
#! from the top down.
namestack* vector-length namestack-search ;
namestack (get) ;
: set ( value variable -- ) namespace set-hash ;
: put ( variable value -- ) swap set ;
@ -90,10 +83,3 @@ DEFER: namespace
: 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 ) namespace hash-keys ;
: values ( -- list ) namespace hash-values ;
! We don't have bound objects in native Factor.
: has-namespace? hashtable? ;

9
library/platform/native/parse-syntax.factor
View File

@ -35,7 +35,6 @@ USE: lists
USE: logic
USE: math
USE: namespaces
USE: parser
USE: stack
USE: strings
USE: words
@ -114,6 +113,14 @@ USE: unparser
IN: syntax
: recursive-infer ( -- )
#! Mark the last word to be recursively inferred (eg, cond).
word t "recursive-infer" set-word-property ; parsing
: inline ( -- )
#! Mark the last word to be inlined.
word t "inline" set-word-property ; parsing
! The variable "in-definition" is set inside a : ... ;.
! ( and #! then add "stack-effect" and "documentation"
! properties to the current word if it is set.

14
library/platform/native/parser.factor
View File

@ -55,12 +55,6 @@ USE: unparser
drop f
] ifte ;
: parsing ( -- )
#! Mark the most recently defined word to execute at parse
#! time, rather than run time. The word can use 'scan' to
#! read ahead in the input stream.
word t "parsing" set-word-property ;
: end? ( -- ? )
"col" get "line" get str-length >= ;
@ -188,6 +182,14 @@ USE: unparser
: next-word-ch ( -- ch )
"col" get "line" get skip-blank "col" set next-ch ;
IN: syntax
: parsing ( -- )
#! Mark the most recently defined word to execute at parse
#! time, rather than run time. The word can use 'scan' to
#! read ahead in the input stream.
word t "parsing" set-word-property ;
! Once this file has loaded, we can use 'parsing' normally.
! This hack is needed because in Java Factor, 'parsing' is
! not parsing, but in CFactor, it is.

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

@ -194,7 +194,7 @@ USE: words
[ add-copy-io-task " from to callback -- " [ 3 | 1 ] ]
[ pending-io-error " -- " [ 0 | 0 ] ]
[ next-io-task " -- callback " [ 0 | 1 ] ]
[ room " -- free total " [ 0 | 2 ] ]
[ room " -- free total free total " [ 0 | 4 ] ]
[ os-env " str -- str " [ 1 | 1 ] ]
[ millis " -- n " [ 0 | 1 ] ]
[ init-random " -- " [ 0 | 0 ] ]

5
library/presentation.factor
View File

@ -27,6 +27,7 @@
IN: presentation
USE: combinators
USE: hashtables
USE: kernel
USE: lists
USE: namespaces
@ -44,10 +45,10 @@ USE: unparser
! significance to the 'fwrite-attr' word when applied to a
! stream that supports attributed string output.
: (style) ( name -- style ) "styles" get get* ;
: (style) ( name -- style ) "styles" get hash ;
: default-style ( -- style ) "default" (style) ;
: style ( name -- style ) (style) [ default-style ] unless* ;
: set-style ( style name -- ) "styles" get set* ;
: set-style ( style name -- ) "styles" get set-hash ;
<namespace> "styles" set

4
library/prettyprint.factor
View File

@ -225,9 +225,9 @@ DEFER: prettyprint*
: {.} ( vector -- )
#! Unparse each element on its own line.
[ . ] vector-each ;
stack>list [ . ] each ;
: .n namestack {.} ;
: .n namestack [.] ;
: .s datastack {.} ;
: .r callstack {.} ;
: .c catchstack {.} ;

8
library/test/hashtables.factor
View File

@ -34,8 +34,6 @@ unit-test
[ t ] [ [ f | t ] hashcode [ f | t ] hashcode = ] unit-test
[ t ] [ [ 1 [ 2 3 ] 4 ] hashcode [ 1 [ 2 3 ] 4 ] hashcode = ] unit-test
native? [
[ t ] [ 12 hashcode 12 hashcode = ] unit-test
[ t ] [ 12 >bignum hashcode 12 hashcode = ] unit-test
[ t ] [ 12.0 hashcode 12 >bignum hashcode = ] unit-test
] when
[ t ] [ 12 hashcode 12 hashcode = ] unit-test
[ t ] [ 12 >bignum hashcode 12 hashcode = ] unit-test
[ t ] [ 12.0 hashcode 12 >bignum hashcode = ] unit-test

24
library/test/inference.factor
View File

@ -7,7 +7,24 @@ USE: combinators
USE: vectors
USE: kernel
USE: lists
USE: namespaces
[
[ 1 | 2 ]
[ 2 | 1 ]
[ 0 | 3 ]
[ 4 | 2 ]
[ 3 | 3 ]
[ 0 | 0 ]
[ 1 | 5 ]
[ 3 | 4 ]
] "effects" set
[ t ] [
"effects" get [
dup [ 7 | 7 ] decompose compose [ 7 | 7 ] =
] all?
] unit-test
[ 6 ] [ 6 gensym-vector vector-length ] unit-test
[ 3 ] [ [ { 1 2 } { 1 2 3 } ] max-vector-length ] unit-test
@ -122,5 +139,12 @@ DEFER: foe
! [ [ 1 | 1 ] ] [ [ last ] infer ] unit-test
! [ [ 1 | 1 ] ] [ [ list? ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ bitor ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ bitand ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ bitxor ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ mod ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ /i ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ /f ] infer ] unit-test
[ [ 2 | 2 ] ] [ [ /mod ] infer ] unit-test
[ [ 2 | 1 ] ] [ [ number= ] infer ] unit-test

3
library/test/words.factor
View File

@ -52,3 +52,6 @@ word word-name "last-word-test" set
[ "test-scope" ] [
"test-scope" [ "scratchpad" ] search word-name
] unit-test
[ t ] [ vocabs list? ] unit-test
[ t ] [ vocabs [ words [ word? ] all? ] all? ] unit-test

14
library/tools/debugger.factor
View File

@ -55,15 +55,13 @@ USE: unparser
: in-parser? ( -- ? )
"error-line" get "error-col" get and ;
: error-handler-hook
#! The game overrides this.
;
: :s ( -- ) "error-datastack" get {.} ;
: :r ( -- ) "error-callstack" get {.} ;
: :n ( -- ) "error-namestack" get {.} ;
: :n ( -- ) "error-namestack" get [.] ;
: :c ( -- ) "error-catchstack" get {.} ;
: :get ( var -- value ) "error-namestack" get (get) ;
: default-error-handler ( error -- )
#! Print the error and return to the top level.
[
@ -71,8 +69,6 @@ USE: unparser
[ :s :r :n :c ] [ prettyprint-word " " write ] each
"show stacks at time of error." print
java? [ ":j shows Java stack trace." print ] when
error-handler-hook
\ :get prettyprint-word
" ( var -- value ) inspects the error namestack." print
] when* ;

86
library/tools/inference.factor
View File

@ -46,13 +46,20 @@ USE: hashtables
! - meta-infer -- evaluate word in meta-interpreter if set.
! - infer - quotation with custom inference behavior; ifte uses
! this. Word is passed on the stack.
! - recursive-infer - if true, inferencer will always invoke
! itself recursively with this word, instead of solving a
! fixed-point equation for recursive calls.
! Amount of results we had to add to the datastack
SYMBOL: d-in
! Amount of results we had to add to the callstack
SYMBOL: r-in
! Recursive state. Alist maps words to base case effects
! Recursive state. Alist maps words to hashmaps...
SYMBOL: recursive-state
! ... with keys:
SYMBOL: base-case
SYMBOL: entry-effect
: gensym-vector ( n -- vector )
dup <vector> swap [ gensym over vector-push ] times ;
@ -108,10 +115,23 @@ SYMBOL: recursive-state
: no-effect ( word -- )
"Unknown stack effect: " swap word-name cat2 throw ;
: (effect) ( -- [ in | stack ] )
d-in get meta-d get cons ;
: effect ( -- [ in | out ] )
#! After inference is finished, collect information.
d-in get meta-d get vector-length cons ;
: <recursive-state> ( -- state )
<namespace> [
base-case off effect entry-effect set
] extend ;
DEFER: (infer)
: apply-compound ( word -- )
t over recursive-state acons@
#! Infer a compound word's stack effect.
dup <recursive-state> cons recursive-state cons@
word-parameter (infer)
recursive-state uncons@ drop ;
@ -127,9 +147,12 @@ DEFER: (infer)
#! Push word we're currently inferring effect of.
recursive-state get car car ;
: no-base-case ( -- )
current-word word-name
" does not have a base case." cat2 throw ;
: current-state ( -- word )
#! Push word we're currently inferring effect of.
recursive-state get car cdr ;
: no-base-case ( word -- )
word-name " does not have a base case." cat2 throw ;
: check-recursion ( -- )
#! If at the location of the recursive call, we're taking
@ -139,19 +162,33 @@ DEFER: (infer)
current-word word-name " diverges." cat2 throw
] when ;
: recursive-word ( word effect -- )
: recursive-word ( word state -- )
#! Handle a recursive call, by either applying a previously
#! inferred base case, or raising an error.
dup t = [ drop no-base-case ] [ nip consume/produce ] ifte ;
base-case swap hash dup [
nip consume/produce
] [
drop no-base-case
] ifte ;
: apply-object ( obj -- )
#! Apply the object's stack effect to the inferencer state.
#! There are three options: recursive-infer words always
#! cause a recursive call of the inferencer, regardless.
#! Be careful, you might hang the inferencer. Other words
#! solve a fixed-point equation if a recursive call is made,
#! otherwise the inferencer is invoked recursively if its
#! not a recursive call.
dup word? [
dup recursive-state get assoc [
dup "recursive-infer" word-property [
apply-word
] [
dup recursive-state get assoc dup [
check-recursion recursive-word
] [
apply-word
] ifte*
drop apply-word
] ifte
] ifte
] [
push-d
] ifte ;
@ -162,10 +199,6 @@ DEFER: (infer)
0 r-in set
f recursive-state set ;
: effect ( -- [ in | out ] )
#! After inference is finished, collect information.
d-in get meta-d get vector-length cons ;
: (infer) ( quot -- )
#! Recursive calls to this word are made for nested
#! quotations.
@ -174,10 +207,7 @@ DEFER: (infer)
: infer-branch ( quot -- [ in-d | datastack ] )
#! Infer the quotation's effect, restoring the meta
#! interpreter state afterwards.
[
copy-interpreter (infer)
d-in get meta-d get cons
] with-scope ;
[ copy-interpreter (infer) (effect) ] with-scope ;
: difference ( [ in | stack ] -- diff )
#! Stack height difference of infer-branch return value.
@ -216,14 +246,26 @@ DEFER: (infer)
"Unbalanced branches" throw
] ifte ;
: compose ( first second -- total )
#! Stack effect composition.
>r uncons r> uncons >r -
dup 0 < [ neg + r> cons ] [ r> + cons ] ifte ;
: decompose ( first second -- solution )
#! Return a stack effect such that first*solution = second.
2dup 2car
2dup > [ "No solution to decomposition" throw ] when
swap - -rot 2cdr >r + r> cons ;
: set-base ( [ in | stack ] -- )
#! Set the base case of the current word.
recursive-state uncons@ car >r
uncons vector-length cons r>
recursive-state acons@ ;
uncons vector-length cons
current-state [
entry-effect get swap decompose base-case set
] bind ;
: recursive-branch ( quot -- )
#! Set base case if inference didn't fail.
#! Set base case if inference didn't fail
[ infer-branch set-base ] [ [ drop ] when ] catch ;
: infer-branches ( brachlist -- )

8
library/tools/inspector.factor
View File

@ -46,7 +46,7 @@ USE: vectors
: vars. ( -- )
#! Print a list of defined variables.
vars [ print ] each ;
namespace hash-keys [.] ;
: object-actions ( -- alist )
[
@ -82,9 +82,6 @@ USE: vectors
: alist-sort ( list -- list )
[ swap car unparse swap car unparse str-lexi> ] sort ;
: describe-namespace ( namespace -- )
[ vars-values ] bind alist-sort describe-assoc ;
: describe-hashtable ( hashtables -- )
hash>alist alist-sort describe-assoc ;
@ -99,9 +96,6 @@ USE: vectors
[ assoc? ]
[ describe-assoc ]
[ has-namespace? ]
[ describe-namespace ]
[ hashtable? ]
[ describe-hashtable ]

54
library/tools/interpreter.factor
View File

@ -60,16 +60,16 @@ SYMBOL: meta-cf
: init-interpreter ( -- )
10 <vector> meta-r set
10 <vector> meta-d set
10 <vector> meta-n set
10 <vector> meta-c set
f meta-n set
f meta-c set
f meta-cf set ;
: copy-interpreter ( -- )
#! Copy interpreter state from containing namespaces.
meta-r get vector-clone meta-r set
meta-d get vector-clone meta-d set
meta-n get vector-clone meta-n set
meta-c get vector-clone meta-c set ;
meta-n get meta-n set
meta-c get meta-c set ;
: done-cf? ( -- ? )
meta-cf get not ;
@ -135,10 +135,10 @@ SYMBOL: meta-cf
\ r> [ pop-r push-d ] set-meta-word
\ callstack [ meta-r get vector-clone push-d ] set-meta-word
\ set-callstack [ pop-d vector-clone meta-r set ] set-meta-word
\ namestack* [ meta-n get push-d ] set-meta-word
\ set-namestack* [ pop-d meta-n set ] set-meta-word
\ catchstack* [ meta-c get push-d ] set-meta-word
\ set-catchstack* [ pop-d meta-c set ] set-meta-word
\ namestack [ meta-n get push-d ] set-meta-word
\ set-namestack [ pop-d meta-n set ] set-meta-word
\ catchstack [ meta-c get push-d ] set-meta-word
\ set-catchstack [ pop-d meta-c set ] set-meta-word
\ call [ pop-d meta-call ] set-meta-word
\ execute [ pop-d meta-word ] set-meta-word
\ ifte [ pop-d pop-d pop-d [ nip ] [ drop ] ifte meta-call ] set-meta-word
@ -162,22 +162,6 @@ SYMBOL: meta-cf
meta-d get set-datastack
] with-scope ;
: walk-banner ( -- )
"The following words control the single-stepper:" print
"&s -- print stepper data stack" print
"&r -- print stepper call stack" print
"&n -- print stepper name stack" print
"&c -- print stepper catch stack" print
"step -- single step" print
"(trace) -- trace until end" print
"(run) -- run until end" print ;
: walk ( quot -- )
#! Single-step through execution of a quotation.
init-interpreter
meta-cf set
walk-banner ;
: &s
#! Print stepper data stack.
meta-d get {.} ;
@ -188,15 +172,35 @@ SYMBOL: meta-cf
: &n
#! Print stepper name stack.
meta-n get {.} ;
meta-n get [.] ;
: &c
#! Print stepper catch stack.
meta-c get {.} ;
: &get ( var -- value )
#! Print stepper variable value.
meta-n get (get) ;
: not-done ( quot -- )
done? [ "Stepper is done." print drop ] [ call ] ifte ;
: step
#! Step into current word.
[ next dup report do ] not-done ;
: walk-banner ( -- )
"The following words control the single-stepper:" print
[ &s &r &n &c ] [ prettyprint-word " " write ] each
"show stepper stacks." print
\ &get prettyprint-word
" ( var -- value ) inspects the stepper namestack." print
\ step prettyprint-word " -- single step" print
\ (trace) prettyprint-word " -- trace until end" print
\ (run) prettyprint-word " -- run until end" print ;
: walk ( quot -- )
#! Single-step through execution of a quotation.
init-interpreter
meta-cf set
walk-banner ;

25
library/tools/listener.factor
View File

@ -44,12 +44,7 @@ USE: unparser
USE: vectors
: print-banner ( -- )
[
"This is " ,
java? [ "JVM " , ] when
native? [ "native " , ] when
"Factor " , version ,
] make-string print
"Factor " write version print
"Copyright (C) 2003, 2004 Slava Pestov" print
"Copyright (C) 2004 Chris Double" print
"Type ``exit'' to exit, ``help'' for help." print ;
@ -74,22 +69,30 @@ USE: vectors
listener-step listener-loop
] ifte ;
: kb. 1024 /i unparse write " KB" write ;
: (room.) ( free total -- )
2dup swap - swap ( free used total )
kb. " total " write
kb. " used " write
kb. " free" print ;
: room. ( -- )
room
1024 /i unparse write " KB total, " write
1024 /i unparse write " KB free" print ;
"Data space: " write (room.)
"Code space: " write (room.) ;
: init-listener ( -- )
print-banner
terpri
room.
terpri
listener-loop ;
: help ( -- )
"SESSION:" print
native? [
"\"foo.image\" save-image -- save heap to a file" print
] when
"room. -- show memory usage" print
"heap-stats. -- memory allocation breakdown" print
"garbage-collection -- force a GC" print
@ -114,7 +117,7 @@ USE: vectors
"PROFILER: [ ... ] call-profile" print
" [ ... ] allot-profile" print
"TRACE: [ ... ] trace" print
"SINGLE STEP: [ ... ] step" print
"SINGLE STEP: [ ... ] walk" print
terpri
"HTTP SERVER: USE: httpd 8888 httpd" print
"TELNET SERVER: USE: telnetd 9999 telnetd" print ;

7
library/tools/telnetd.factor
View File

@ -46,12 +46,7 @@ USE: threads
] with-stream ;
: telnet-connection ( socket -- )
#! We don't do multitasking in JFactor.
java? [
telnet-client
] [
[ telnet-client ] in-thread drop
] ifte ;
[ telnet-client ] in-thread drop ;
: quit-flag ( -- ? )
global [ "telnetd-quit-flag" get ] bind ;

5
library/vocabulary-style.factor
View File

@ -27,6 +27,7 @@
IN: presentation
USE: combinators
USE: hashtables
USE: lists
USE: kernel
USE: namespaces
@ -36,10 +37,10 @@ USE: words
: vocab-style ( vocab -- style )
#! Each vocab has a style object specifying how words are
#! to be printed.
"vocabularies" style get* ;
"vocabularies" style hash ;
: set-vocab-style ( style vocab -- )
>r default-style append r> "vocabularies" style set* ;
>r default-style append r> "vocabularies" style set-hash ;
: word-style ( word -- style )
word-vocabulary [ vocab-style ] [ default-style ] ifte* ;

7
library/words.factor
View File

@ -27,6 +27,7 @@
IN: words
USE: combinators
USE: hashtables
USE: kernel
USE: lists
USE: logic
@ -42,11 +43,11 @@ USE: strings
: vocabs ( -- list )
#! Push a list of vocabularies.
global [ "vocabularies" get [ vars str-sort ] bind ] bind ;
global [ "vocabularies" get hash-keys str-sort ] bind ;
: vocab ( name -- vocab )
#! Get a vocabulary.
global [ "vocabularies" get get* ] bind ;
global [ "vocabularies" get hash ] bind ;
: word-sort ( list -- list )
#! Sort a list of words by name.
@ -55,7 +56,7 @@ USE: strings
: words ( vocab -- list )
#! Push a list of all words in a vocabulary.
#! Filter empty slots.
vocab [ values ] bind [ ] subset word-sort ;
vocab hash-values [ ] subset word-sort ;
: each-word ( quot -- )
#! Apply a quotation to each word in the image.

3
native/memory.c
View File

@ -71,7 +71,8 @@ bool in_zone(ZONE* z, CELL pointer)
void primitive_room(void)
{
/* push: free total */
box_integer(compiling.limit - compiling.here);
box_integer(compiling.limit - compiling.base);
box_integer(active.limit - active.here);
box_integer(active.limit - active.base);
}