!
! 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/
!
! Then, enter this at the interpreter prompt:
!
-! "contrib/mandel.factor" run-file
+! "examples/mandel.factor" run-file
IN: mandel
* A growable array.
* @author Slava Pestov
*/
-public class FactorArray implements FactorExternalizable, PublicCloneable
+public class FactorArray implements FactorExternalizable
{
public Object[] array;
public int top;
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}
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;
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(
errorSource);
FactorReader r = new FactorReader(scanner,
false,FactorPlugin.getExternalInstance());
-
+
Cons parsed = r.parse();
-
+
d.in = r.getIn();
d.use = r.getUse();
-
+
addWordDefNodes(d,parsed,buffer);
}
catch(FactorParseException pe)
0,0,0,e.toString());
Log.log(Log.DEBUG,this,e);
}
- finally
- {
- buffer.readUnlock();
- }
return d;
} //}}}
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 });
}
//{{{ public void actionPerformed() method
public void actionPerformed(ActionEvent evt)
{
- showPreview();
+ try
+ {
+ showPreview();
+ }
+ catch(IOException e)
+ {
+ throw new RuntimeException(e);
+ }
} //}}}
- //{{{ showPreview() method
- private void showPreview()
+ //{{{ getWordAtCaret() method
+ private FactorWord getWordAtCaret(FactorParsedData fdata)
+ throws IOException
{
- View view = textArea.getView();
+ int line = textArea.getCaretLine();
+ int caret = textArea.getCaretPosition();
- SideKickParsedData data = SideKickParsedData.getParsedData(view);
- if(data instanceof FactorParsedData)
- {
- int line = textArea.getCaretLine();
- int caret = textArea.getCaretPosition();
+ DefaultTokenHandler h = new DefaultTokenHandler();
+ textArea.getBuffer().markTokens(line,h);
+ Token tokens = h.getTokens();
- DefaultTokenHandler h = new DefaultTokenHandler();
- textArea.getBuffer().markTokens(line,h);
- Token tokens = h.getTokens();
+ int offset = caret - textArea.getLineStartOffset(line);
- int offset = caret - textArea.getLineStartOffset(line);
+ int len = textArea.getLineLength(line);
+ if(len == 0)
+ return null;
- int len = textArea.getLineLength(line);
- if(len == 0)
- return;
+ if(offset == len)
+ offset--;
- if(offset == len)
- offset--;
+ Token token = TextUtilities.getTokenAtOffset(tokens,offset);
- Token token = TextUtilities.getTokenAtOffset(tokens,offset);
+ String name = token.rules.getName();
- String name = token.rules.getName();
+ for(int i = 0; i < IGNORED_RULESETS.length; i++)
+ {
+ if(name.equals(IGNORED_RULESETS[i]))
+ return null;
+ }
- for(int i = 0; i < IGNORED_RULESETS.length; i++)
- {
- if(name.equals(IGNORED_RULESETS[i]))
- return;
- }
+ String word = FactorPlugin.getWordAtCaret(textArea);
+ if(word == null)
+ return null;
+
+ return FactorPlugin.getExternalInstance()
+ .searchVocabulary(fdata.use,word);
+ } //}}}
- String word = FactorPlugin.getWordAtCaret(textArea);
- if(word == null)
- return;
+ //{{{ showPreview() method
+ private void showPreview()
+ throws IOException
+ {
+ View view = textArea.getView();
- FactorParsedData fdata = (FactorParsedData)data;
+ if(SideKickPlugin.isParsingBuffer(view.getBuffer()))
+ return;
- try
- {
- FactorWord w = FactorPlugin.getExternalInstance()
- .searchVocabulary(fdata.use,word);
- if(w != null)
- {
- view.getStatus().setMessageAndClear(
- FactorWordRenderer.getWordHTMLString(
- w,true));
- }
- }
- catch(IOException e)
+ SideKickParsedData data = SideKickParsedData.getParsedData(view);
+ if(data instanceof FactorParsedData)
+ {
+ FactorWord w = getWordAtCaret((FactorParsedData)data);
+ if(w != null)
{
- throw new RuntimeException(e);
+ view.getStatus().setMessageAndClear(
+ FactorWordRenderer.getWordHTMLString(
+ w,true));
}
}
} //}}}
#! 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
IN: files
USE: combinators
+USE: hashtables
USE: lists
USE: logic
USE: namespaces
] ;
: 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 ;
] ifte ;
: resource-responder ( filename -- )
- java? "resource-path" get or [
+ "resource-path" get [
serve-resource
] [
drop "404 resource-path not set" httpd-error
IN: httpd-responder
USE: combinators
+USE: hashtables
USE: httpd
USE: kernel
USE: lists
] 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 ;
: 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 ;
IN: logging
-USE: namespaces
USE: combinators
+USE: hashtables
+USE: namespaces
USE: stack
USE: streams
USE: strings
: log-client ( -- )
"client" get [
"Accepted connection from " swap
- "client" swap get* cat2 log
+ "client" swap hash cat2 log
] when* ;
: with-logging ( quot -- )
#! 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
IN: namespaces
USE: combinators
+USE: hashtables
USE: kernel
USE: lists
USE: logic
: 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
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* ;
namespace swap (object-path) ;
: (set-object-path) ( name -- namespace )
- dup namespace get* dup [
+ dup namespace hash dup [
nip
] [
drop <namespace> tuck put
"/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"
"/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
: set-boot ( quot -- )
#! Set the boot quotation.
8 setenv ;
-
-: java? f ;
-: native? t ;
-
-! No compiler...
-: inline ;
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 ;
#! 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 )
- ] [
- pred 2dup >r >r namestack* vector-nth hash* dup [
- r> drop r> drop ( [ key | value ] -- ) cdr ( found )
+ dup [
+ 2dup car hash* dup [
+ nip nip 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 ;
: 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? ;
USE: logic
USE: math
USE: namespaces
-USE: parser
USE: stack
USE: strings
USE: words
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.
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 >= ;
: 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.
[ 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 ] ]
IN: presentation
USE: combinators
+USE: hashtables
USE: kernel
USE: lists
USE: namespaces
! 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
: {.} ( vector -- )
#! Unparse each element on its own line.
- [ . ] vector-each ;
+ stack>list [ . ] each ;
-: .n namestack {.} ;
+: .n namestack [.] ;
: .s datastack {.} ;
: .r callstack {.} ;
: .c catchstack {.} ;
[ 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
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
! [ [ 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
[ "test-scope" ] [
"test-scope" [ "scratchpad" ] search word-name
] unit-test
+
+[ t ] [ vocabs list? ] unit-test
+[ t ] [ vocabs [ words [ word? ] all? ] all? ] unit-test
: 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.
[
[ :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* ;
! - 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 ;
: 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 ;
#! 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
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 [
- check-recursion recursive-word
- ] [
+ dup "recursive-infer" word-property [
apply-word
- ] ifte*
+ ] [
+ dup recursive-state get assoc dup [
+ check-recursion recursive-word
+ ] [
+ drop apply-word
+ ] ifte
+ ] ifte
] [
push-d
] ifte ;
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.
: 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.
"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 -- )
: vars. ( -- )
#! Print a list of defined variables.
- vars [ print ] each ;
+ namespace hash-keys [.] ;
: object-actions ( -- alist )
[
: 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 ;
[ assoc? ]
[ describe-assoc ]
- [ has-namespace? ]
- [ describe-namespace ]
-
[ hashtable? ]
[ describe-hashtable ]
: 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 ;
\ 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
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 {.} ;
: &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 ;
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 ;
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
+ "\"foo.image\" save-image -- save heap to a file" print
"room. -- show memory usage" print
"heap-stats. -- memory allocation breakdown" print
"garbage-collection -- force a GC" print
"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 ;
] 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 ;
IN: presentation
USE: combinators
+USE: hashtables
USE: lists
USE: kernel
USE: namespaces
: 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* ;
IN: words
USE: combinators
+USE: hashtables
USE: kernel
USE: lists
USE: logic
: 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.
: 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.
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);
}
projects / factor.git / commitdiff