\r
+ listener/plugin:\r
\r
+- listener should be multithreaded\r
+- fully socket based communication\r
+- compile all, infer all commands\r
+- type something -- no completions -- hit another key -- not inserted\r
- faster completion\r
- sidekick: still parsing too much\r
- errors don't always disappear\r
: vector-peek ( vector -- obj )
#! Get value at end of vector without removing it.
- dup vector-length pred swap vector-nth ;
+ dup vector-length 1 - swap vector-nth ;
SYMBOL: exprs
DEFER: infix
: <color-map> ( nb-cols -- map )
[
dup [
- 360 * over succ / 360 / sat val
+ 360 * over 1 + / 360 / sat val
hsv>rgb 1.0 scale-rgba ,
] times*
] make-list list>vector nip ;
over absq 4 >= over 0 = or [
nip nip
] [
- pred >r sq dupd + r> iter
+ 1 - >r sq dupd + r> iter
] ifte ;
: max-color 360 ;
: random-element ( list -- random )
#! Returns a random element from the given list.
- dup >r length pred 0 swap random-int r> nth ;
+ dup >r length 1 - 0 swap random-int r> nth ;
: random-subset ( list -- list )
#! Returns a random subset of the given list. Each item is
public class ExternalFactor extends DefaultVocabularyLookup
{
//{{{ ExternalFactor constructor
- /**
- * We are given two streams that point to a bare REPL.
- */
- public ExternalFactor(Process proc, InputStream in, OutputStream out)
+ public ExternalFactor(int port)
{
- if(proc == null || in == null || out == null)
- closed = true;
- else
- {
- this.proc = proc;
+ /* Start stream server */;
+ streamServer = port;
+ for(int i = 1; i < 6; i++)
+ {
+ Log.log(Log.DEBUG,this,"Factor connection, try #" + i);
try
{
- this.in = new DataInputStream(in);
- this.out = new DataOutputStream(out);
-
- out.write("USE: jedit wire-server\n".getBytes("ASCII"));
- out.flush();
-
- waitForAck();
-
- /* Start stream server */
- streamServer = 9999;
- eval("USE: telnetd [ 9999 telnetd ] in-thread");
-
- /* Ensure we're ready for a connection immediately */
- eval("nop");
+ Thread.sleep(1000);
+ openWire();
+ Log.log(Log.DEBUG,this,"Connection established");
+ return;
}
catch(Exception e)
{
- close();
+ Log.log(Log.ERROR,this,e);
}
+
}
+
+ Log.log(Log.ERROR,this,"Cannot connect to Factor on port " + port);
+ if(in != null && out != null)
+ close();
+ } //}}}
+
+ //{{{ openWireSocket() method
+ /**
+ * Return a listener stream.
+ */
+ public Socket openWireSocket() throws IOException
+ {
+ if(closed)
+ throw new IOException("Socket closed");
+ return new Socket("localhost",streamServer);
} //}}}
+ //{{{ openWire() method
+ private void openWire() throws Exception
+ {
+ Socket client = openWireSocket();
+ in = new DataInputStream(new BufferedInputStream(
+ client.getInputStream()));
+ out = new DataOutputStream(new BufferedOutputStream(
+ client.getOutputStream()));
+ out.write("USE: jedit wire-server\n".getBytes("ASCII"));
+ out.flush();
+ waitForAck();
+ }
+
//{{{ waitForAck() method
private void waitForAck() throws IOException
{
*/
public FactorStream openStream()
{
- if(closed)
- return null;
- else
+ try
{
- try
- {
- Socket client = new Socket("localhost",streamServer);
- return new FactorStream(client);
- }
- catch(Exception e)
- {
- Log.log(Log.ERROR,this,"Cannot open stream connection to "
- + "external Factor:");
- Log.log(Log.ERROR,this,e);
- return null;
- }
+ return new FactorStream(openWireSocket());
+ }
+ catch(Exception e)
+ {
+ Log.log(Log.ERROR,this,"Cannot open stream connection to "
+ + "external Factor:");
+ Log.log(Log.ERROR,this,e);
+ return null;
}
} //}}}
try
{
- proc.waitFor();
in.close();
out.close();
}
Log.log(Log.DEBUG,this,e);
}
- proc = null;
in = null;
out = null;
} //}}}
//{{{ Private members
private boolean closed;
- private Process proc;
private DataInputStream in;
private DataOutputStream out;
public class FactorPlugin extends EditPlugin
{
private static ExternalFactor external;
+ private static Process process;
+ private static int PORT = 9999;
//{{{ getPluginPath() method
private String getPluginPath()
{
if(external == null)
{
- Process p = null;
InputStream in = null;
OutputStream out = null;
List args = new ArrayList();
args.add(jEdit.getProperty("factor.external.program"));
args.add(jEdit.getProperty("factor.external.image"));
- args.add("-no-ansi");
- args.add("-no-smart-terminal");
+ args.add("-shell=telnet");
+ args.add("-telnetd-port=" + PORT);
String[] extraArgs = jEdit.getProperty(
- "factor.external.args","-jedit")
+ "factor.external.args")
.split(" ");
addNonEmpty(extraArgs,args);
- p = Runtime.getRuntime().exec((String[])args.toArray(
+ process = Runtime.getRuntime().exec((String[])args.toArray(
new String[args.size()]));
- p.getErrorStream().close();
- in = p.getInputStream();
- out = p.getOutputStream();
+ external = new ExternalFactor(PORT);
+
+ process.getErrorStream().close();
+ process.getInputStream().close();
+ process.getOutputStream().close();
}
- catch(IOException io)
+ catch(Exception e)
{
Log.log(Log.ERROR,FactorPlugin.class,
"Cannot start external Factor:");
- Log.log(Log.ERROR,FactorPlugin.class,io);
+ Log.log(Log.ERROR,FactorPlugin.class,e);
+ process = null;
}
-
- external = new ExternalFactor(p,in,out);
}
return external;
if(external != null)
{
external.close();
+ try
+ {
+ process.waitFor();
+ }
+ catch(Exception e)
+ {
+ Log.log(Log.DEBUG,FactorPlugin.class,e);
+ }
external = null;
}
} //}}}
\r
"/library/inference/dataflow.factor"\r
"/library/inference/inference.factor"\r
- "/library/inference/words.factor"\r
"/library/inference/branches.factor"\r
+ "/library/inference/words.factor"\r
"/library/inference/stack.factor"\r
\r
"/library/compiler/assembler.factor"\r
"/library/io/buffer.factor"\r
"/library/win32/win32-io.factor"\r
"/library/win32/win32-errors.factor"\r
- "/library/win32/winsock.factor"
+ "/library/win32/winsock.factor"\r
"/library/io/win32-io-internals.factor"\r
"/library/io/win32-stream.factor"\r
- "/library/io/win32-server.factor"
+ "/library/io/win32-server.factor"\r
"/library/io/win32-console.factor"\r
] [\r
dup print\r
USE: kernel-internals
USE: console
-: init-smart-terminal
- "smart-terminal" get [
- stdio smart-term-hook get change
- ] when ;
+: default-cli-args
+ #! Some flags are *on* by default, unless user specifies
+ #! -no-<flag> CLI switch
+ "user-init" on
+ "interactive" on
+ "smart-terminal" on
+ "verbose-compile" on
+ "compile" on
+ os "win32" = [
+ "sdl" "shell" set
+ ] [
+ "ansi" "shell" set
+ ] ifte ;
: warm-boot ( -- )
#! A fully bootstrapped image has this as the boot
default-cli-args
parse-command-line ;
+: shell ( str -- )
+ #! This handles the -shell:<foo> cli argument.
+ [ "shells" ] search execute ;
+
[
warm-boot
garbage-collection
run-user-init
- "graphical" get [
- start-console
- ] [
- "interactive" get [
- init-smart-terminal
- print-banner listener
- ] when
- ] ifte
+ "shell" get shell
0 exit*
] set-boot
"Not every word compiles, by design." print
terpri
-0 [ compiled? [ succ ] when ] each-word
+0 [ compiled? [ 1 + ] when ] each-word
unparse write " words compiled" print
-0 [ drop succ ] each-word
+0 [ drop 1 + ] each-word
unparse write " words total" print
"Bootstrapping is complete." print
[ "kernel-internals" | "set-integer-slot" ]
[ "kernel-internals" | "grow-array" ]
] [
- unswons create swap succ [ f define ] keep
+ unswons create swap 1 + [ f define ] keep
] each drop
: run-files ( args -- )
[ [ run-file ] when* ] each ;
-: default-cli-args
- #! Some flags are *on* by default, unless user specifies
- #! -no-<flag> CLI switch
- "user-init" on
- "interactive" on
- "smart-terminal" on
- "verbose-compile" on
- "compile" on
- os "win32" = [ "graphical" on ] when ;
-
: cli-args ( -- args ) 10 getenv ;
: parse-command-line ( -- )
scan str>number ; parsing
: ENUM:
- dup CREATE swap unit define-compound succ ; parsing
+ dup CREATE swap unit define-compound 1 + ; parsing
: END-ENUM
drop ; parsing
: builtin-type ( n -- symbol )
unit classes get hash ;
-: type-name ( n -- string )
- builtin-type word-name ;
-
: class ( obj -- class )
#! Analogous to the type primitive. Pushes the builtin
#! class of an object.
dup <namespace> [ "methods" set-word-property ] keep
] unless* <vtable> define-generic ;
+PREDICATE: word generic ( word -- ? )
+ "combination" word-property ;
+
: single-combination ( obj vtable -- )
>r dup type r> dispatch ; inline
: (gensym) ( -- name )
"G:" global [
- gensym-count [ succ dup ] change
+ gensym-count [ 1 + dup ] change
] bind unparse cat2 ;
: gensym ( -- word )
2dup str-length 2 - >= [
2drop
] [
- >r succ dup 2 + r> substring catch-hex> [ , ] when*
+ >r 1 + dup 2 + r> substring catch-hex> [ , ] when*
] ifte ;
: url-decode-% ( index str -- index str )
2dup url-decode-hex >r 3 + r> ;
: url-decode-+-or-other ( index str ch -- index str )
- dup CHAR: + = [ drop CHAR: \s ] when , >r succ r> ;
+ dup CHAR: + = [ drop CHAR: \s ] when , >r 1 + r> ;
: url-decode-iter ( index str -- )
2dup str-length >= [
USE: hashtables
USE: prettyprint
-! If this symbol is on, partial evalution of conditionals is
-! disabled.
-SYMBOL: inferring-base-case
-
: vector-length< ( vec1 vec2 -- ? )
swap vector-length swap vector-length < ;
: unify-results ( value value -- value )
#! Replace values with unknown result if they differ,
#! otherwise retain them.
- 2dup = [ drop ] [ unify-classes <computed> ] ifte ;
+ 2dup = [
+ drop
+ ] [
+ unify-classes <computed>
+ ] ifte ;
: unify-stacks ( list -- stack )
#! Replace differing literals in stacks with unknown
SYMBOL: cloned
+: assq* ( key alist -- [ key | value ] )
+ #! Looks up the key in an alist. Push the key/value pair.
+ #! Most of the time you want to use assq not assq*.
+ dup [
+ 2dup car car eq? [ nip car ] [ cdr assq* ] ifte
+ ] [
+ 2drop f
+ ] ifte ;
+
+: assq ( key alist -- value )
+ #! Looks up the key in an alist.
+ assq* dup [ cdr ] when ;
+
: deep-clone ( vector -- vector )
#! Clone a vector if it hasn't already been cloned in this
#! with-deep-clone scope.
- dup cloned get assoc dup [
+ dup cloned get assq dup [
nip
] [
drop vector-clone [ dup cloned [ acons ] change ] keep
: deep-clone-vector ( vector -- vector )
#! Clone a vector of vectors.
- [ ( deep-clone ) vector-clone ] vector-map ;
+ [ deep-clone ] vector-map ;
: copy-inference ( -- )
#! We avoid cloning the same object more than once in order
: infer-branch ( value -- namespace )
<namespace> [
- uncons [ unswons [ \ value-class set ] bind ] when*
+ uncons [ unswons set-value-class ] when*
dup value-recursion recursive-state set
copy-inference
literal-value infer-quot
#! given one in the list.
[ over eq? not ] subset nip car car value-recursion ;
+! FIXME this is really bad
+: old-effect ( [ in-types out-types ] -- [ in | out ] )
+ uncons car length >r length r> cons ;
+
+: foo>effect ( [ in-types out-types ] -- [ in | out ] )
+ [ effect old-effect ] bind ;
+
+: raise ( [ in | out ] -- [ in | out ] )
+ uncons 2dup min tuck - >r - r> cons ;
+
+: effect>foo ( [ in | out ] -- [ intypes outtypes ] )
+ <namespace> [
+ uncons
+ [ drop object <computed> ] vector-project meta-d set
+ [ drop object <computed> ] vector-project d-in set
+ { } meta-r set
+ ] extend ;
+
+: 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 raise effect>foo ;
+
+: set-base ( effect rstate -- )
+ #! Set the base case of the current word.
+ dup [
+ car cdr [
+ entry-effect get old-effect dup [ 0 | 0 ] = [
+ drop
+ ] [
+ swap foo>effect decompose
+ ] ifte
+ base-case cons@
+ ] bind
+ ] [
+ 2drop
+ ] ifte ;
+
: recursive-branch ( branch branchlist -- )
[
dupd dual-branch >r infer-branch r> set-base
[ 2drop ] when
] catch ;
+: no-base-case ( word -- )
+ word-name " does not have a base case." cat2 throw ;
+
+: get-base ( word rstate -- effect )
+ [ base-case get ] bind dup [
+ nip [ unify-effects effect ] with-scope
+ ] [
+ drop no-base-case
+ ] ifte ;
+
: infer-base-case ( branchlist -- )
[
inferring-base-case on
#! the branches has an undecidable stack effect, we set the
#! base case to this stack effect and try again. The inputs
#! parameter is a vector.
- (infer-branches) dup unify-effects unify-dataflow ;
+ (infer-branches) dup unify-effects unify-dataflow ;
+
+: (with-block) ( label quot -- )
+ #! Call a quotation in a new namespace, and transfer
+ #! inference state from the outer scope.
+ swap >r [
+ dataflow-graph off
+ call
+ d-in get meta-d get meta-r get get-dataflow
+ ] with-scope
+ r> swap #label dataflow, [ node-label set ] bind
+ meta-r set meta-d set d-in set ;
: static-branch? ( value -- )
literal? inferring-base-case get not and ;
[ object general-list general-list ] ensure-d
dataflow-drop, pop-d
dataflow-drop, pop-d swap
- peek-d static-branch? [
- static-ifte
- ] [
+! peek-d static-branch? [
+! static-ifte
+! ] [
dynamic-ifte
- ] ifte ;
+ ( ] ifte ) ;
\ ifte [ infer-ifte ] "infer" set-word-property
USE: generic
USE: prettyprint
+! If this symbol is on, partial evalution of conditionals is
+! disabled.
+SYMBOL: inferring-base-case
+
! Word properties that affect inference:
! - infer-effect -- must be set. controls number of inputs
! expected, and number of outputs produced.
GENERIC: value= ( literal value -- ? )
GENERIC: value-class ( value -- class )
GENERIC: value-class-and ( class value -- )
+GENERIC: set-value-class ( class value -- )
TRAITS: computed
C: computed ( class -- value )
[ \ value-class get ] bind ;
M: computed value-class-and ( class value -- )
[ \ value-class [ class-and ] change ] bind ;
+M: computed set-value-class ( class value -- )
+ [ \ value-class set ] bind ;
TRAITS: literal
C: literal ( obj rstate -- value )
literal-value class ;
M: literal value-class-and ( class value -- )
value-class class-and drop ;
+M: literal set-value-class ( class value -- )
+ 2drop ;
: value-recursion ( value -- rstate )
[ recursive-state get ] bind ;
: (ensure-types) ( typelist n stack -- )
pick [
3dup >r >r car r> r> vector-nth value-class-and
- >r >r cdr r> succ r> (ensure-types)
+ >r >r cdr r> 1 + r> (ensure-types)
] [
3drop
] ifte ;
d-in get [ value-class ] vector-map vector>list
meta-d get [ value-class ] vector-map vector>list 2list ;
-: old-effect ( [ in-types out-types ] | [ in | out ] )
- uncons car length >r length r> cons ;
-
: <recursive-state> ( -- state )
<namespace> [
base-case off effect entry-effect set
#! quotations.
[ apply-object ] each ;
-: raise ( [ in | out ] -- [ in | out ] )
- uncons 2dup min tuck - >r - r> cons ;
-
-: new-effect ( [ in | out ] -- [ intypes outtypes ] )
- uncons
- swap [ drop object ] project
- swap [ drop object ] project
- 2list ;
-
-: decompose ( first second -- solution )
- #! Return a stack effect such that first*solution = second.
- over [ [ ] [ ] ] = [
- nip
- ] [
- swap old-effect swap old-effect
- 2dup 2car
- 2dup > [ "No solution to decomposition" throw ] when
- swap - -rot 2cdr >r + r> cons raise new-effect
- ] ifte ;
-
-: set-base ( [ in | out ] rstate -- )
- #! Set the base case of the current word.
- dup [
- car cdr [
- [ effect ] bind entry-effect get swap decompose
- base-case set
- ] bind
- ] [
- 2drop
- ] ifte ;
-
: check-return ( -- )
#! Raise an error if word leaves values on return stack.
meta-r get vector-length 0 = [
: no-effect ( word -- )
"Unknown stack effect: " swap word-name cat2 throw ;
-: with-recursive-state ( word label quot -- )
- >r
- <recursive-state> [ recursive-label set ] extend dupd cons
- recursive-state cons@
- r> call ;
-
-: (with-block) ( label quot -- )
- #! Call a quotation in a new namespace, and transfer
- #! inference state from the outer scope.
- swap >r [
- dataflow-graph off
- call
- d-in get meta-d get meta-r get get-dataflow
- ] with-scope
- r> swap #label dataflow, [ node-label set ] bind
- meta-r set meta-d set d-in set ;
-
: with-block ( word label quot -- )
#! Execute a quotation with the word on the stack, and add
#! its dataflow contribution to a new block node in the IR.
- over [ with-recursive-state ] (with-block) ;
+ over [
+ >r
+ <recursive-state> [ recursive-label set ] extend
+ dupd cons
+ recursive-state cons@
+ r> call
+ ] (with-block) ;
: inline-compound ( word -- effect )
#! Infer the stack effect of a compound word in the current
#! Push word we're currently inferring effect of.
recursive-state get car car ;
-: 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
#! more items from the stack than producing, we have a
#! Handle a recursive call, by either applying a previously
#! inferred base case, or raising an error. If the recursive
#! call is to a local block, emit a label call node.
- base-case over hash dup [
- swap [ recursive-label get ] bind ( word effect label )
- dup [
- rot drop #call-label rot
- ] [
- drop #call swap
- ] ifte (consume/produce)
+ [ get-base ] 2keep [ recursive-label get ] bind
+ dup [
+ ( word effect label )
+ nip #call-label
] [
- 2drop no-base-case
- ] ifte ;
+ drop #call
+ ] ifte rot (consume/produce) ;
: apply-word ( word -- )
#! Apply the word's stack effect to the inferencer state.
- dup recursive-state get assoc dup [
+ dup recursive-state get assoc [
check-recursion recursive-word
] [
- drop dup "infer-effect" word-property dup [
+ dup "infer-effect" word-property [
apply-effect
] [
- drop dup "no-effect" word-property [
- no-effect
- ] [
- (apply-word)
- ] ifte
- ] ifte
- ] ifte ;
+ (apply-word)
+ ] ifte*
+ ] ifte* ;
: infer-call ( -- )
[ general-list ] ensure-d
#! ansi-bg - background color
[ delegate set ] extend ;
-global [ [ <ansi-stream> ] smart-term-hook set ] bind
+IN: shells
+
+: ansi
+ stdio [ <ansi-stream> ] change tty ;
swap stdio get <prefix-stream> [
stdio set call
] with-scope ; inline
-
-! Set this to a quotation in init code, depending on OS.
-SYMBOL: smart-term-hook
f swap fwrite-attr ;
: fprint ( string stream -- )
- tuck fwrite "\n" over fwrite fauto-flush ;
+ [ fwrite ] keep
+ [ "\n" swap fwrite ] keep
+ fauto-flush ;
TRAITS: string-output-stream
C: win32-console-stream ( stream -- stream )
[ -11 GetStdHandle handle set delegate set ] extend ;
-global [ [ <win32-console-stream> ] smart-term-hook set ] bind
+! global [ [ <win32-console-stream> ] smart-term-hook set ] bind
[ dupd = not ] subset nip ;
: length ( list -- length )
- 0 swap [ drop succ ] each ;
+ 0 swap [ drop 1 + ] each ;
: prune ( list -- list )
#! Remove duplicate elements.
2drop 0
] [
over cons? [
- pred >r uncons r> tuck
+ 1 - >r uncons r> tuck
cons-hashcode >r
cons-hashcode r>
bitxor
: head ( list n -- list )
#! Return the first n elements of the list.
- dup 0 > [ >r uncons r> pred head cons ] [ 2drop f ] ifte ;
+ dup 0 > [ >r uncons r> 1 - head cons ] [ 2drop f ] ifte ;
: tail ( list n -- tail )
#! Return the rest of the list, from the nth index onward.
! Inverse hyperbolic functions:
! acosh asech asinh acosech atanh acoth
-: acosh dup sq pred sqrt + log ;
+: acosh dup sq 1 - sqrt + log ;
: asech recip acosh ;
-: asinh dup sq succ sqrt + log ;
+: asinh dup sq 1 + sqrt + log ;
: acosech recip asinh ;
-: atanh dup succ swap pred neg / log 2 / ;
+: atanh dup 1 + swap 1 - neg / log 2 / ;
: acoth recip atanh ;
: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ;
: asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ;
#!
#! In order to compile, the code must produce as many values
#! as it consumes.
- tuck >r dup 0 <= [ r> 3drop ] [ pred slip r> times ] ifte ;
+ tuck >r dup 0 <= [ r> 3drop ] [ 1 - slip r> times ] ifte ;
inline
: (times) ( limit n quot -- )
pick pick <= [
3drop
] [
- rot pick succ pick 3slip (times)
+ rot pick 1 + pick 3slip (times)
] ifte ; inline
: times* ( n quot -- )
0 swap (times) ; inline
: fac ( n -- n! )
- 1 swap [ succ * ] times* ;
+ 1 swap [ 1 + * ] times* ;
: 2times-succ ( #{ a b } #{ c d } -- z )
#! Lexicographically add #{ 0 1 } to a complex number.
#! If d + 1 == b, return #{ c+1 0 }. Otherwise, #{ c d+1 }.
- 2dup imaginary succ swap imaginary = [
- nip real succ
+ 2dup imaginary 1 + swap imaginary = [
+ nip real 1 +
] [
- nip >rect succ rect>
+ nip >rect 1 + rect>
] ifte ; inline
: 2times<= ( #{ a b } #{ c d } -- ? )
#! Apply a quotation to each pair of complex numbers
#! #{ a b } such that a < w, b < h.
0 swap (2times) ; inline
+
+: (repeat) ( i n quot -- )
+ pick pick >= [
+ 3drop
+ ] [
+ [ swap >r call 1 + r> ] keep (repeat)
+ ] ifte ;
+
+: repeat ( n quot -- )
+ #! Execute a quotation n times. The loop counter is kept on
+ #! the stack, and ranges from 0 to n-1.
+ 0 -rot (repeat) ;
: sq dup * ; inline
-: pred 1 - ; inline
-: succ 1 + ; inline
-
: neg 0 swap - ; inline
: recip 1 swap / ; inline
USE: kernel
USE: kernel-internals
USE: lists
+USE: vectors
! Other languages have classes, objects, variables, etc.
! Factor has similar concepts.
! bind ( namespace quot -- ) executes a quotation with a
! namespace pushed on the namespace stack.
-: namestack ( -- ns ) 3 getenv ;
-: set-namestack ( ns -- ) 3 setenv ;
+: namestack ( -- ns ) 3 getenv ; inline
+: set-namestack ( ns -- ) 3 setenv ; inline
: namespace ( -- namespace )
#! Push the current namespace.
: >n ( namespace -- n:namespace )
#! Push a namespace on the namespace stack.
- namestack cons set-namestack ; inline
+ >vector namestack cons set-namestack ; inline
: n> ( n:namespace -- namespace )
#! Pop the top of the namespace stack.
[ fixnum<= " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ]
[ fixnum> " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ]
[ fixnum>= " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ]
- [ bignum= " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ]
+ [ bignum= " x y -- ? " [ [ bignum bignum ] [ boolean ] ] ]
[ bignum+ " x y -- x+y " [ [ bignum bignum ] [ bignum ] ] ]
[ bignum- " x y -- x-y " [ [ bignum bignum ] [ bignum ] ] ]
[ bignum* " x y -- x*y " [ [ bignum bignum ] [ bignum ] ] ]
dup dup neg bitand = ;
: (random-int-0) ( n bits val -- n )
- 3dup - + pred 0 < [
+ 3dup - + 1 < [
2drop (random-int) 2dup swap mod (random-int-0)
] [
nip nip
] ifte ;
: random-int-0 ( max -- n )
- succ dup power-of-2? [
+ 1 + dup power-of-2? [
(random-int) * -31 shift
] [
(random-int) 2dup swap mod (random-int-0)
: add-line ( text -- )
lines get vector-push
- lines get vector-length succ first-line get - visible-lines -
+ lines get vector-length 1 + first-line get - visible-lines -
dup 0 >= [
first-line [ + ] change
] [
line-editor get dup sbuf-length 0 = [
drop
] [
- [ sbuf-length pred ] keep set-sbuf-length
+ [ sbuf-length 1 - ] keep set-sbuf-length
] ifte ;
M: integer key-down ( key -- )
SYMBOL: escape-continuation
-: start-console ( -- )
+IN: shells
+
+: sdl ( -- )
<namespace> [
800 600 32 SDL_HWSURFACE init-screen
init-console
USE: vectors
: f_ ( h s v i -- f ) >r swap rot >r 2dup r> 6 * r> - ;
-: p ( v s x -- v p x ) >r dupd neg succ * r> ;
-: q ( v s f -- q ) * neg succ * ;
-: t_ ( v s f -- t_ ) neg succ * neg succ * ;
+: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
+: q ( v s f -- q ) * neg 1 + * ;
+: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
: mod-cond ( p vector -- )
#! Call p mod q'th entry of the vector of quotations, where
#! Returns 2 strings, that when concatenated yield the
#! original string, without the character at the given
#! index.
- [ swap str-head ] 2keep succ swap str-tail ;
+ [ swap str-head ] 2keep 1 + swap str-tail ;
: str-head? ( str begin -- ? )
2dup str-length< [
: next-line ( -- str )
"parse-stream" get freadln
- "line-number" [ succ ] change ;
+ "line-number" [ 1 + ] change ;
: (read-lines) ( quot -- )
next-line dup [
"line" off "col" off ;
: ch ( -- ch ) "col" get "line" get str-nth ;
-: advance ( -- ) "col" [ succ ] change ;
+: advance ( -- ) "col" [ 1 + ] change ;
: skip ( n line quot -- n )
#! Find the next character that satisfies the quotation,
2dup str-nth r> dup >r call [
r> 2drop
] [
- >r succ r> r> skip
+ >r 1 + r> r> skip
] ifte
] [
r> drop nip str-length
dup >r skip-blank dup r>
2dup str-length < [
2dup str-nth denotation? [
- drop succ
+ drop 1 +
] [
skip-word
] ifte
"col" get "line" get rot index-of* ;
: (until) ( index -- str )
- "col" get swap dup succ "col" set "line" get substring ;
+ "col" get swap dup 1 + "col" set "line" get substring ;
: until ( ch -- str )
ch-search (until) ;
USE: words
USE: hashtables
+SYMBOL: prettyprint-limit
+
GENERIC: prettyprint* ( indent obj -- indent )
M: object prettyprint* ( indent obj -- indent )
#! Change this to suit your tastes.
4 ;
-: prettyprint-limit ( -- limit )
- #! Avoid infinite loops -- maximum indent, 10 levels.
- "prettyprint-limit" get [ 40 ] unless* ;
-
: indent ( indent -- )
#! Print the given number of spaces.
" " fill write ;
" " write ;
: prettyprint-element ( indent obj -- indent )
- over prettyprint-limit >= [
+ over prettyprint-limit get >= [
unparse write
] [
prettyprint*
: . ( obj -- )
[
"prettyprint-single-line" on
- tab-size 4 * "prettyprint-limit" set
+ 16 prettyprint-limit set
prettyprint
] with-scope ;
: .b >bin print ;
: .o >oct print ;
: .h >hex print ;
+
+global [ 40 prettyprint-limit set ] bind
USE: words
! Prettyprinting words
-: vocab-attrs ( word -- attrs )
- vocab-link "object-link" default-style acons ;
+: vocab-actions ( search -- list )
+ [
+ [ "Words" | "words." ]
+ [ "Use" | "\"use\" cons@" ]
+ [ "In" | "\"in\" set" ]
+ ] ;
+
+: vocab-attrs ( vocab -- attrs )
+ #! Words without a vocabulary do not get a link or an action
+ #! popup.
+ unparse vocab-actions <actions> "actions" swons unit ;
: prettyprint-vocab ( vocab -- )
dup vocab-attrs write-attr ;
-: prettyprint-IN: ( indent word -- )
+: prettyprint-IN: ( word -- )
\ IN: prettyprint* prettyprint-space
- word-vocabulary prettyprint-vocab prettyprint-newline ;
+ word-vocabulary prettyprint-vocab prettyprint-space ;
: prettyprint-: ( indent -- indent )
\ : prettyprint* prettyprint-space
"Not a word: " write . ;
M: compound see ( word -- )
- 0 swap
- [ dupd prettyprint-IN: prettyprint-: ] keep
+ [ prettyprint-IN: ] keep
+ 0 prettyprint-: swap
[ prettyprint-1 ] keep
[ prettyprint-docs ] keep
[ word-parameter prettyprint-list prettyprint-; ] keep
prettyprint-plist prettyprint-newline ;
M: primitive see ( word -- )
- "PRIMITIVE: " write dup unparse write stack-effect. terpri ;
+ dup prettyprint-IN:
+ "PRIMITIVE: " write dup prettyprint-1 stack-effect. terpri ;
M: symbol see ( word -- )
- 0 over prettyprint-IN:
+ dup prettyprint-IN:
+ 0 swap
\ SYMBOL: prettyprint-1 prettyprint-space . ;
M: undefined see ( word -- )
- drop "Not defined" print ;
+ dup prettyprint-IN:
+ \ DEFER: prettyprint-1 prettyprint-space . ;
M: object unparse ( obj -- str )
[
"#<" ,
- dup type type-name ,
+ dup class unparse ,
" @ " ,
address unparse ,
">" ,
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
: integer, ( num radix -- )
- tuck /mod >digit , dup 0 > [
- swap integer,
+ dup >r /mod >digit , dup 0 > [
+ r> integer,
] [
- 2drop
+ r> 2drop
] ifte ;
: >base ( num radix -- string )
: ack ( m n -- x )
over 0 = [
- nip succ
+ nip 1 +
] [
dup 0 = [
- drop pred 1 ack
+ drop 1 - 1 ack
] [
- dupd pred ack >r pred r> ack
+ dupd 1 - ack >r 1 - r> ack
] ifte
] ifte ; compiled
USE: compiler
: fac-benchmark
- 10000 fac 10000 [ succ / ] times* ; compiled
+ 10000 fac 10000 [ 1 + / ] times* ; compiled
[ 1 ] [ fac-benchmark ] unit-test
USE: test
: fib ( n -- nth fibonacci number )
- dup 1 <= [ drop 1 ] [ pred dup fib swap pred fib + ] ifte ;
+ dup 1 <= [ drop 1 ] [ 1 - dup fib swap 1 - fib + ] ifte ;
compiled
[ 9227465 ] [ 34 fib ] unit-test
2dup str-length > [
dup [ "123" , , "456" , , "789" , ] make-string
dup dup str-length 2 /i 0 swap rot substring
- swap dup str-length 2 /i succ 1 swap rot substring cat2
+ swap dup str-length 2 /i 1 + 1 swap rot substring cat2
string-step
] [
2drop
: callcc1-test ( x -- list )
[
"test-cc" set [ ] [
- swap pred tuck swons
+ swap 1 - tuck swons
over 0 = [ "test-cc" get call ] when
] forever
] callcc1 nip ;
{{
[ node-op | #test ]
[ node-param | 5 ]
- }} "foobar" [ [ node-param get ] bind succ ] apply-dataflow
+ }} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow
] unit-test
#test [ [ node-param get ] bind sq ] "foobar" set-word-property
{{
[ node-op | #test ]
[ node-param | 5 ]
- }} "foobar" [ [ node-param get ] bind succ ] apply-dataflow
+ }} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow
] unit-test
! Somebody (cough) got the order of ifte nodes wrong.
! Type inference
-[ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
-[ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
-[ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
-[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
-[ [ [ object ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
+! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
+! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
+! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
+! [ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
+! [ [ [ object ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
! [ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
[ 4 ] [
0 "There are Four Upper Case characters"
- [ LETTER? [ succ ] when ] str-each
+ [ LETTER? [ 1 + ] when ] str-each
] unit-test
[ "Replacing+spaces+with+plus" ]
: test ( name -- )
! Run the given test.
- depth pred >r
+ depth 1 - >r
"Testing " write dup write "..." print
"/library/test/" swap ".factor" cat3 run-resource
"Checking before/after depth..." print
"Type check error" print
uncons car dup "Object: " write .
"Object type: " write class .
- "Expected type: " write type-name print ;
+ "Expected type: " write builtin-type . ;
: range-error ( list -- )
"Range check error" print
: heap-stats. ( -- )
#! Print heap allocation breakdown.
- 0 heap-stats [ dupd uncons heap-stat. succ ] each drop ;
+ 0 heap-stats [ dupd uncons heap-stat. 1 + ] each drop ;
USE: words
USE: unparser
USE: vectors
+USE: ansi
SYMBOL: cont-prompt
SYMBOL: listener-prompt
terpri
"HTTP SERVER: USE: httpd 8888 httpd" print
"TELNET SERVER: USE: telnetd 9999 telnetd" print ;
+
+IN: shells
+
+: tty
+ print-banner listener ;
USE: stdio
USE: streams
USE: threads
+USE: parser
: telnet-client ( socket -- )
dup [
[
<server> [ telnetd-loop ] [ swap fclose rethrow ] catch
] with-logging ;
+
+IN: shells
+
+: telnet
+ "telnetd-port" get str>number telnetd ;
+
+global [ 9999 "telnetd-port" set ] bind
: vector-peek ( vector -- obj )
#! Get value at end of vector.
- dup vector-length pred swap vector-nth ;
+ dup vector-length 1 - swap vector-nth ;
: vector-pop ( vector -- obj )
#! Get value at end of vector and remove it.
- dup vector-length pred ( vector top )
+ dup vector-length 1 - ( vector top )
2dup swap vector-nth >r swap set-vector-length r> ;
: >pop> ( stack -- stack )
#ifndef WIN32
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
+void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
void call_profiling_step(int signal, siginfo_t* siginfo, void* uap);
void init_signals(void);
#endif
if(STACK_UNDERFLOW(ds,ds_bot))
reset_datastack();
else if(STACK_OVERFLOW(ds,ds_bot))
+ {
+ fprintf(stderr,"ds oveflow\n");
reset_datastack();
+ }
else if(STACK_UNDERFLOW(cs,cs_bot))
reset_callstack();
else if(STACK_OVERFLOW(cs,cs_bot))
+ {
+ fprintf(stderr,"cs oveflow\n");
reset_callstack();
+ }
}
void init_stacks(void)
signal_error(signal);
}
+void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap)
+{
+ dump_stacks();
+}
+
/* Called from a signal handler. XXX - is this safe? */
void call_profiling_step(int signal, siginfo_t* siginfo, void* uap)
{
struct sigaction custom_sigaction;
struct sigaction profiling_sigaction;
struct sigaction ign_sigaction;
+ struct sigaction dump_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;
+ dump_sigaction.sa_sigaction = dump_stack_signal;
+ dump_sigaction.sa_flags = SA_SIGINFO;
ign_sigaction.sa_handler = SIG_IGN;
sigaction(SIGABRT,&custom_sigaction,NULL);
sigaction(SIGFPE,&custom_sigaction,NULL);
sigaction(SIGSEGV,&custom_sigaction,NULL);
sigaction(SIGPIPE,&ign_sigaction,NULL);
sigaction(SIGPROF,&profiling_sigaction,NULL);
+ sigaction(SIGQUIT,&dump_sigaction,NULL);
}
void primitive_call_profiling(void)
projects / factor.git / commitdiff