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

type inference changes, comment out smart-terminal reference in win32-console, win32-compatible factor plugin

cvs
Slava Pestov 2004-12-29 08:35:46 +00:00
parent d632a1dfc7
commit 81705a955d
54 changed files with 358 additions and 258 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
TODO.FACTOR.txt
View File

@ -34,6 +34,10 @@
+ listener/plugin:
- listener should be multithreaded
- fully socket based communication
- compile all, infer all commands
- type something -- no completions -- hit another key -- not inserted
- faster completion
- sidekick: still parsing too much
- errors don't always disappear

2
examples/infix.factor
View File

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

4
examples/mandel.factor
View File

@ -44,7 +44,7 @@ USE: test
: <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 ;
@ -55,7 +55,7 @@ USE: test
over absq 4 >= over 0 = or [
nip nip
] [
pred >r sq dupd + r> iter
1 - >r sq dupd + r> iter
] ifte ;
: max-color 360 ;

2
examples/more-random.factor
View File

@ -14,7 +14,7 @@ USE: namespaces
: 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

77
factor/ExternalFactor.java
View File

@ -40,41 +40,57 @@ import org.gjt.sp.util.Log;
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)
{
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
{
@ -131,15 +147,10 @@ public class ExternalFactor extends DefaultVocabularyLookup
* Return a listener stream.
*/
public FactorStream openStream()
{
if(closed)
return null;
else
{
try
{
Socket client = new Socket("localhost",streamServer);
return new FactorStream(client);
return new FactorStream(openWireSocket());
}
catch(Exception e)
{
@ -148,7 +159,6 @@ public class ExternalFactor extends DefaultVocabularyLookup
Log.log(Log.ERROR,this,e);
return null;
}
}
} //}}}
//{{{ getVocabularies() method
@ -279,7 +289,6 @@ public class ExternalFactor extends DefaultVocabularyLookup
try
{
proc.waitFor();
in.close();
out.close();
}
@ -289,7 +298,6 @@ public class ExternalFactor extends DefaultVocabularyLookup
Log.log(Log.DEBUG,this,e);
}
proc = null;
in = null;
out = null;
} //}}}
@ -303,7 +311,6 @@ public class ExternalFactor extends DefaultVocabularyLookup
//{{{ Private members
private boolean closed;
private Process proc;
private DataInputStream in;
private DataOutputStream out;

34
factor/jedit/FactorPlugin.java
View File

@ -42,6 +42,8 @@ import sidekick.*;
public class FactorPlugin extends EditPlugin
{
private static ExternalFactor external;
private static Process process;
private static int PORT = 9999;
//{{{ getPluginPath() method
private String getPluginPath()
@ -101,7 +103,6 @@ public class FactorPlugin extends EditPlugin
{
if(external == null)
{
Process p = null;
InputStream in = null;
OutputStream out = null;
@ -110,27 +111,28 @@ public class FactorPlugin extends EditPlugin
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;
@ -153,6 +155,14 @@ public class FactorPlugin extends EditPlugin
if(external != null)
{
external.close();
try
{
process.waitFor();
}
catch(Exception e)
{
Log.log(Log.DEBUG,FactorPlugin.class,e);
}
external = null;
}
} //}}}

2
library/bootstrap/boot-stage2.factor
View File

@ -114,8 +114,8 @@ USE: namespaces
"/library/inference/dataflow.factor"
"/library/inference/inference.factor"
"/library/inference/words.factor"
"/library/inference/branches.factor"
"/library/inference/words.factor"
"/library/inference/stack.factor"
"/library/compiler/assembler.factor"

34
library/bootstrap/init-stage2.factor
View File

@ -45,10 +45,19 @@ USE: unparser
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
@ -59,18 +68,15 @@ USE: console
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
@ -136,10 +142,10 @@ terpri
"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

2
library/bootstrap/primitives.factor
View File

@ -223,5 +223,5 @@ vocabularies get [
[ "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

10
library/cli.factor
View File

@ -82,16 +82,6 @@ USE: kernel-internals
: 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 ( -- )

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

@ -53,7 +53,7 @@ USE: words
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

3
library/generic/builtin.factor
View File

@ -77,9 +77,6 @@ builtin 50 "priority" set-word-property
: 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.

3
library/generic/generic.factor
View File

@ -118,6 +118,9 @@ USE: math-internals
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

2
library/gensym.factor
View File

@ -36,7 +36,7 @@ SYMBOL: gensym-count
: (gensym) ( -- name )
"G:" global [
gensym-count [ succ dup ] change
gensym-count [ 1 + dup ] change
] bind unparse cat2 ;
: gensym ( -- word )

4
library/httpd/url-encoding.factor
View File

@ -49,14 +49,14 @@ USE: unparser
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 >= [

97
library/inference/branches.factor
View File

@ -39,10 +39,6 @@ USE: words
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 < ;
@ -65,7 +61,11 @@ SYMBOL: inferring-base-case
: 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
@ -109,10 +109,23 @@ SYMBOL: inferring-base-case
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
@ -120,7 +133,7 @@ SYMBOL: cloned
: 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
@ -133,7 +146,7 @@ SYMBOL: cloned
: 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
@ -151,6 +164,45 @@ SYMBOL: cloned
#! 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
@ -158,6 +210,16 @@ SYMBOL: cloned
[ 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
@ -194,6 +256,17 @@ SYMBOL: cloned
#! parameter is a vector.
(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 ;
@ -221,11 +294,11 @@ SYMBOL: cloned
[ 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

45
library/inference/inference.factor
View File

@ -39,6 +39,10 @@ USE: hashtables
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.
@ -64,6 +68,7 @@ GENERIC: literal-value ( value -- obj )
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 )
@ -79,6 +84,8 @@ M: computed value-class ( value -- class )
[ \ 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 )
@ -91,6 +98,8 @@ M: literal value-class ( value -- class )
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 ;
@ -98,7 +107,7 @@ M: literal value-class-and ( class value -- )
: (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 ;
@ -131,9 +140,6 @@ M: literal value-class-and ( class value -- )
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
@ -162,37 +168,6 @@ DEFER: apply-word
#! 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 = [

53
library/inference/words.factor
View File

@ -78,27 +78,16 @@ USE: prettyprint
: 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
@ -131,9 +120,6 @@ M: symbol (apply-word) ( word -- )
#! 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
@ -147,32 +133,25 @@ M: symbol (apply-word) ( word -- )
#! 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 )
[ get-base ] 2keep [ recursive-label get ] bind
dup [
rot drop #call-label rot
( word effect label )
nip #call-label
] [
drop #call swap
] ifte (consume/produce)
] [
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 ;
] ifte*
] ifte* ;
: infer-call ( -- )
[ general-list ] ensure-d

5
library/io/ansi.factor
View File

@ -91,4 +91,7 @@ C: ansi-stream ( stream -- stream )
#! ansi-bg - background color
[ delegate set ] extend ;
global [ [ <ansi-stream> ] smart-term-hook set ] bind
IN: shells
: ansi
stdio [ <ansi-stream> ] change tty ;

3
library/io/stdio.factor
View File

@ -77,6 +77,3 @@ C: stdio-stream ( delegate -- stream )
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

4
library/io/stream.factor
View File

@ -48,7 +48,9 @@ GENERIC: fclose ( stream -- )
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

2
library/io/win32-console.factor
View File

@ -85,5 +85,5 @@ M: win32-console-stream fwrite-attr ( string style 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

6
library/lists.factor
View File

@ -126,7 +126,7 @@ DEFER: tree-contains?
[ dupd = not ] subset nip ;
: length ( list -- length )
0 swap [ drop succ ] each ;
0 swap [ drop 1 + ] each ;
: prune ( list -- list )
#! Remove duplicate elements.
@ -168,7 +168,7 @@ M: cons = ( obj cons -- ? )
2drop 0
] [
over cons? [
pred >r uncons r> tuck
1 - >r uncons r> tuck
cons-hashcode >r
cons-hashcode r>
bitxor
@ -191,7 +191,7 @@ M: cons hashcode ( cons -- hash ) 4 cons-hashcode ;
: 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.

6
library/math/arc-trig-hyp.factor
View File

@ -36,11 +36,11 @@ USE: math-internals
! 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 ;

24
library/math/math-combinators.factor
View File

@ -33,14 +33,14 @@ USE: kernel
#!
#! 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 -- )
@ -52,15 +52,15 @@ USE: kernel
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 } -- ? )
@ -77,3 +77,15 @@ USE: kernel
#! 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) ;

3
library/math/math.factor
View File

@ -87,9 +87,6 @@ M: number = ( n n -- ? ) number= ;
: sq dup * ; inline
: pred 1 - ; inline
: succ 1 + ; inline
: neg 0 swap - ; inline
: recip 1 swap / ; inline

7
library/namespaces.factor
View File

@ -30,6 +30,7 @@ USE: hashtables
USE: kernel
USE: kernel-internals
USE: lists
USE: vectors
! Other languages have classes, objects, variables, etc.
! Factor has similar concepts.
@ -50,8 +51,8 @@ USE: lists
! 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.
@ -59,7 +60,7 @@ USE: lists
: >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.

2
library/primitives.factor
View File

@ -98,7 +98,7 @@ USE: words
[ 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 ] ] ]

4
library/random.factor
View File

@ -34,14 +34,14 @@ USE: math
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)

8
library/sdl/console.factor
View File

@ -111,7 +111,7 @@ SYMBOL: line-editor
: 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
] [
@ -198,7 +198,7 @@ M: backspace-key key-down ( key -- )
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 -- )
@ -250,7 +250,9 @@ M: alien handle-event ( event -- ? )
SYMBOL: escape-continuation
: start-console ( -- )
IN: shells
: sdl ( -- )
<namespace> [
800 600 32 SDL_HWSURFACE init-screen
init-console

6
library/sdl/hsv.factor
View File

@ -14,9 +14,9 @@ USE: namespaces
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

2
library/strings.factor
View File

@ -96,7 +96,7 @@ UNION: text string integer ;
#! 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< [

2
library/syntax/parse-stream.factor
View File

@ -42,7 +42,7 @@ USE: strings
: next-line ( -- str )
"parse-stream" get freadln
"line-number" [ succ ] change ;
"line-number" [ 1 + ] change ;
: (read-lines) ( quot -- )
next-line dup [

8
library/syntax/parser.factor
View File

@ -66,7 +66,7 @@ USE: unparser
"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,
@ -75,7 +75,7 @@ USE: unparser
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
@ -101,7 +101,7 @@ USE: unparser
dup >r skip-blank dup r>
2dup str-length < [
2dup str-nth denotation? [
drop succ
drop 1 +
] [
skip-word
] ifte
@ -159,7 +159,7 @@ USE: unparser
"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) ;

12
library/syntax/prettyprint.factor
View File

@ -40,6 +40,8 @@ USE: vectors
USE: words
USE: hashtables
SYMBOL: prettyprint-limit
GENERIC: prettyprint* ( indent obj -- indent )
M: object prettyprint* ( indent obj -- indent )
@ -49,10 +51,6 @@ 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 ;
@ -64,7 +62,7 @@ M: object prettyprint* ( indent obj -- indent )
" " write ;
: prettyprint-element ( indent obj -- indent )
over prettyprint-limit >= [
over prettyprint-limit get >= [
unparse write
] [
prettyprint*
@ -186,7 +184,7 @@ M: hashtable prettyprint* ( indent hashtable -- indent )
: . ( obj -- )
[
"prettyprint-single-line" on
tab-size 4 * "prettyprint-limit" set
16 prettyprint-limit set
prettyprint
] with-scope ;
@ -207,3 +205,5 @@ M: hashtable prettyprint* ( indent hashtable -- indent )
: .b >bin print ;
: .o >oct print ;
: .h >hex print ;
global [ 40 prettyprint-limit set ] bind

30
library/syntax/see.factor
View File

@ -37,15 +37,24 @@ USE: unparser
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
@ -95,19 +104,22 @@ M: object see ( obj -- )
"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 . ;

8
library/syntax/unparser.factor
View File

@ -41,7 +41,7 @@ GENERIC: unparse ( obj -- str )
M: object unparse ( obj -- str )
[
"#<" ,
dup type type-name ,
dup class unparse ,
" @ " ,
address unparse ,
">" ,
@ -51,10 +51,10 @@ M: object unparse ( obj -- str )
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 )

6
library/test/benchmark/ack.factor
View File

@ -7,12 +7,12 @@ USE: test
: 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

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

@ -4,6 +4,6 @@ USE: test
USE: compiler
: fac-benchmark
10000 fac 10000 [ succ / ] times* ; compiled
10000 fac 10000 [ 1 + / ] times* ; compiled
[ 1 ] [ fac-benchmark ] unit-test

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

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

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

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

2
library/test/continuations.factor
View File

@ -9,7 +9,7 @@ USE: test
: 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 ;

4
library/test/dataflow.factor
View File

@ -79,7 +79,7 @@ SYMBOL: #test
{{
[ 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
@ -88,7 +88,7 @@ SYMBOL: #test
{{
[ 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.

10
library/test/inference.factor
View File

@ -215,11 +215,11 @@ SYMBOL: sym-test
! 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

2
library/test/strings.factor
View File

@ -83,7 +83,7 @@ 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" ]

2
library/test/test.factor
View File

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

2
library/tools/debugger.factor
View File

@ -63,7 +63,7 @@ USE: generic
"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

2
library/tools/heap-stats.factor
View File

@ -48,4 +48,4 @@ USE: generic
: 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 ;

6
library/tools/listener.factor
View File

@ -38,6 +38,7 @@ USE: presentation
USE: words
USE: unparser
USE: vectors
USE: ansi
SYMBOL: cont-prompt
SYMBOL: listener-prompt
@ -143,3 +144,8 @@ global [
terpri
"HTTP SERVER: USE: httpd 8888 httpd" print
"TELNET SERVER: USE: telnetd 9999 telnetd" print ;
IN: shells
: tty
print-banner listener ;

8
library/tools/telnetd.factor
View File

@ -34,6 +34,7 @@ USE: namespaces
USE: stdio
USE: streams
USE: threads
USE: parser
: telnet-client ( socket -- )
dup [
@ -52,3 +53,10 @@ USE: threads
[
<server> [ telnetd-loop ] [ swap fclose rethrow ] catch
] with-logging ;
IN: shells
: telnet
"telnetd-port" get str>number telnetd ;
global [ 9999 "telnetd-port" set ] bind

4
library/vectors.factor
View File

@ -75,11 +75,11 @@ BUILTIN: vector 11
: 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 )

1
native/signal.h
View File

@ -1,5 +1,6 @@
#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

6
native/stack.c
View File

@ -15,11 +15,17 @@ void fix_stacks(void)
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)

9
native/unix/signal.c
View File

@ -15,6 +15,11 @@ void signal_handler(int signal, siginfo_t* siginfo, void* uap)
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)
{
@ -36,10 +41,13 @@ void init_signals(void)
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);
@ -47,6 +55,7 @@ void init_signals(void)
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)