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

\ foo is now a first-class type; this removes the need for inference-level partial eval, and simplifies a lot of other code

cvs
Slava Pestov 2005-08-04 03:56:28 +00:00
parent 3948beb8f0
commit f65aa407e9
29 changed files with 157 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
CHANGES.html
View File

@ -25,17 +25,23 @@
<b>"usr/bin/grep"</b></pre></li>
<li>Integers now support the sequence protocol. An integer is an increasing sequence of its predecessors. This means the <code>count ( n -- [ 0 ... n-1 ] )</code> word is gone; just use <code>&gt;vector</code> instead. Also, <code>project</code> has been made redundant by <code>map</code>.</li>
<li>The <code>seq-transpose ( seq -- seq )</code> word is now named <code>flip</code>.
</ul>
</li>
</ul>
<ul>Everything else:
</li>
<li>Everything else:
<ul>
<li>Object slots are now clickable in the inspector</li>
<li>The matrices library has been greatly simplified. Matrices are now represented as vectors of vectors, and matrix words have been moved to the <code>math</code> vocabulary.</li>
<li>More descriptive "out of bounds" errors.</li>
</ul>
</li>
</ul>
<h1>Factor 0.76:</h1>
<ul>

3
Makefile
View File

@ -54,7 +54,8 @@ OBJS = $(PLAF_OBJS) native/arithmetic.o native/array.o native/bignum.o \
native/debug.o \
native/hashtable.o \
native/icache.o \
native/io.o
native/io.o \
native/wrapper.o
default:
@echo "Run 'make' with one of the following parameters:"

1
library/bootstrap/boot-stage1.factor
View File

@ -90,7 +90,6 @@ parser prettyprint sequences io vectors words ;
"/library/inference/branches.factor"
"/library/inference/words.factor"
"/library/inference/stack.factor"
"/library/inference/partial-eval.factor"
"/library/inference/class-infer.factor"
"/library/inference/optimizer.factor"
"/library/inference/inline-methods.factor"

1
library/bootstrap/boot-stage3.factor
View File

@ -67,7 +67,6 @@ t [
"/library/tools/word-tools.factor"
"/library/syntax/see.factor"
"/library/test/test.factor"
"/library/inference/test.factor"
"/library/tools/walker.factor"
"/library/tools/annotations.factor"
"/library/tools/inspector.factor"

12
library/bootstrap/image.factor
View File

@ -47,6 +47,7 @@ SYMBOL: boot-quot
: hashtable-type 10 ; inline
: vector-type 11 ; inline
: string-type 12 ; inline
: wrapper-type 14 ; inline
: word-type 17 ; inline
: tuple-type 18 ; inline
@ -173,8 +174,15 @@ M: f ' ( obj -- ptr )
image get [ dup word? [ fixup-word ] when ] nmap ;
M: word ' ( word -- pointer )
transfer-word dup pooled-object
dup [ nip ] [ drop ] ifte ;
transfer-word dup pooled-object [ ] [ ] ?ifte ;
( Wrappers )
M: wrapper ' ( wrapper -- pointer )
wrapped '
object-tag here-as >r
wrapper-type >header emit
emit r> ;
( Conses )

1
library/bootstrap/primitives.factor
View File

@ -208,6 +208,7 @@ vocabularies get [
{ "fflush" "io-internals" [ [ alien ] [ ] ] }
{ "fclose" "io-internals" [ [ alien ] [ ] ] }
{ "expired?" "alien" [ [ object ] [ boolean ] ] }
{ "<wrapper>" "kernel" [ [ object ] [ wrapper ] ] }
} dup length 3 swap [ + ] map-with [
make-primitive
] 2each

8
library/collections/namespaces.factor
View File

@ -1,8 +1,5 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: words
DEFER: literalize
IN: namespaces
USING: hashtables kernel kernel-internals lists math sequences
strings vectors words ;
@ -120,11 +117,6 @@ SYMBOL: building
#! Append to the sequence being built with make-seq.
building get swap nappend ;
: literal, ( word -- )
#! Append some code that pushes the word on the stack. Used
#! when building quotations.
literalize % ;
: make-vector ( quot -- vector )
100 <vector> make-seq ; inline

2
library/compiler/intrinsics.factor
View File

@ -185,7 +185,7 @@ sequences vectors words ;
[[ fixnum> %fixnum> ]]
[[ eq? %eq? ]]
] [
uncons [ literal, \ binary-op , ] make-list
uncons [ literalize , \ binary-op , ] make-list
"intrinsic" set-word-prop
] each

2
library/generic/generic.factor
View File

@ -68,7 +68,7 @@ DEFER: delegate
: dispatcher% "dispatcher" word-prop % ;
: error-method ( generic -- method )
[ dup picker% literal, \ no-method , ] make-list ;
[ dup picker% literalize , \ no-method , ] make-list ;
: empty-method ( generic -- method )
dup "picker" word-prop [ dup ] = [

6
library/generic/tuple.factor
View File

@ -28,7 +28,7 @@ BUILTIN: tuple 18 tuple? ;
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
dup predicate-word
[ \ class , over literal, \ eq? , ] make-list
[ \ class , over literalize , \ eq? , ] make-list
define-predicate ;
: forget-tuple ( class -- )
@ -54,7 +54,7 @@ BUILTIN: tuple 18 tuple? ;
: define-constructor ( word def -- )
>r [ word-name "in" get constructor-word ] keep [
dup literal, "tuple-size" word-prop , \ make-tuple ,
dup literalize , "tuple-size" word-prop , \ make-tuple ,
] make-list r> append define-compound ;
: default-constructor ( tuple -- )
@ -79,7 +79,7 @@ BUILTIN: tuple 18 tuple? ;
[
[
unswons
\ dup , unswons literal, \ eq? , \ drop swons ,
\ dup , unswons literalize , \ eq? , \ drop swons ,
alist>quot , \ ifte ,
] make-list
] when* ;

2
library/inference/inference.factor
View File

@ -58,6 +58,8 @@ GENERIC: apply-object
M: object apply-object apply-literal ;
M: wrapper apply-object wrapped apply-literal ;
: active? ( -- ? )
#! Is this branch not terminated?
d-in get meta-d get and ;

97
library/inference/partial-eval.factor
View File

@ -1,97 +0,0 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: errors generic interpreter kernel lists math namespaces
sequences words ;
: literal-inputs? ( in stack -- )
tail-slice* dup [ safe-literal? ] all?
[ length #drop node, t ] [ drop f ] ifte ;
: literal-inputs ( out stack -- )
tail-slice* [ literal-value ] nmap ;
: literal-outputs ( out stack -- )
tail-slice* dup [ recursive-state get <literal> ] nmap
length #push node, ;
: partial-eval? ( word -- ? )
"infer-effect" word-prop car length
meta-d get literal-inputs? ;
: infer-eval ( word -- )
dup partial-eval? [
dup "infer-effect" word-prop 2unlist
-rot length meta-d get
literal-inputs [
apply-datastack
] [
[ "infer-effect" word-prop consume/produce ]
[ length meta-d get literal-outputs ] ifte
] catch
] [
dup "infer-effect" word-prop consume/produce
] ifte ;
: stateless ( word -- )
#! A stateless word can be evaluated at compile-time.
dup unit [ car infer-eval ] cons "infer" set-word-prop ;
! Could probably add more words here
[
eq?
car
cdr
cons
<
<=
>
>=
number=
+
-
*
/
/i
/f
mod
/mod
bitand
bitor
bitxor
shift
bitnot
>fixnum
>bignum
>float
real
imaginary
] [
stateless
] each
! Partially-evaluated words need their stack effects to be
! entered by hand.
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop
\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop

26
library/inference/test.factor
View File

@ -1,26 +0,0 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: test
USING: errors inference kernel lists namespaces prettyprint
io strings unparser ;
: try-infer ( quot -- effect error )
[ infer f ] [ [ >r drop f r> ] when* ] catch ;
: infer-fail ( quot error -- )
"! " , dup string? [ unparse ] unless , "\n" ,
[ [ infer ] cons . \ unit-test-fails . ] string-out % ;
: infer-pass ( quot effect -- )
[ unit . [ infer ] cons . \ unit-test . ] string-out % ;
: infer>test ( quot -- str )
#! Make a string representing a unit test for the stack
#! effect of a word.
[
dup try-infer [ infer-fail ] [ infer-pass ] ?ifte
] make-string ;
: infer>test. ( word -- )
#! Print a inference unit test for a word.
infer>test write ;

22
library/inference/words.factor
View File

@ -165,3 +165,25 @@ M: compound apply-object ( word -- )
\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop
\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop

6
library/kernel.factor
View File

@ -27,6 +27,12 @@ M: object clone ;
#! Push t if cond is true, otherwise push f.
rot [ drop ] [ nip ] ifte ; inline
DEFER: wrapper?
BUILTIN: wrapper 14 wrapper? { 1 "wrapped" "set-wrapped" } ;
M: wrapper = ( obj wrapper -- ? )
over wrapper? [ swap wrapped = ] [ 2drop f ] ifte ;
! defined in parse-syntax.factor
DEFER: not
DEFER: t?

7
library/syntax/parse-syntax.factor
View File

@ -73,7 +73,12 @@ BUILTIN: f 9 not ;
: \
#! Parsed as a piece of code that pushes a word on the stack
#! \ foo ==> [ foo ] car
scan-word literalize [ swons ] each ; parsing
scan-word literalize swons ; parsing
! Long wrapper syntax. Only used in the rare case that another
! wrapper is being wrapped.
: W[ [ ] ; parsing
: ]W first <wrapper> swons ; parsing
! Vocabularies
: PRIMITIVE:

40
library/syntax/prettyprint.factor
View File

@ -31,30 +31,6 @@ M: word prettyprint* ( indent word -- indent )
: prettyprint-newline ( indent -- )
"\n" write indent ;
: \? ( list -- ? )
#! Is the head of the list a [ foo ] car?
dup car dup cons? [
dup car word? [
cdr [ drop f ] [ second \ car = ] ifte
] [
2drop f
] ifte
] [
2drop f
] ifte ;
: prettyprint-elements ( indent list -- indent )
[
dup \? [
\ \ unparse. bl
uncons >r car unparse. bl
r> cdr prettyprint-elements
] [
uncons >r prettyprint* bl
r> prettyprint-elements
] ifte
] when* ;
: ?prettyprint-newline ( indent -- )
one-line get [ bl drop ] [ prettyprint-newline ] ifte ;
@ -79,6 +55,9 @@ M: word prettyprint* ( indent word -- indent )
recursion-check [ cdr ] change
] ifte ; inline
: prettyprint-elements ( indent list -- indent )
[ prettyprint* bl ] each ;
: prettyprint-sequence ( indent start list end -- indent )
#! Prettyprint a list, with start/end delimiters; eg, [ ],
#! or { }, or << >>. The body of the list is indented,
@ -102,7 +81,7 @@ M: cons prettyprint* ( indent list -- indent )
M: vector prettyprint* ( indent vector -- indent )
[
\ { swap >list \ } prettyprint-sequence
\ { swap \ } prettyprint-sequence
] check-recursion ;
M: hashtable prettyprint* ( indent hashtable -- indent )
@ -112,12 +91,19 @@ M: hashtable prettyprint* ( indent hashtable -- indent )
M: tuple prettyprint* ( indent tuple -- indent )
[
\ << swap <mirror> >list \ >> prettyprint-sequence
\ << swap <mirror> \ >> prettyprint-sequence
] check-recursion ;
M: alien prettyprint* ( alien -- str )
M: alien prettyprint* ( alien -- )
\ ALIEN: unparse. bl alien-address unparse write ;
M: wrapper prettyprint* ( wrapper -- )
dup wrapped word? [
\ \ unparse. bl wrapped unparse.
] [
\ W[ unparse. bl wrapped prettyprint* \ ]W unparse.
] ifte ;
: prettyprint ( obj -- )
[
recursion-check off

24
library/tools/interpreter.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: interpreter
USING: errors kernel kernel-internals lists math namespaces
prettyprint sequences io strings vectors words ;
USING: errors generic io kernel kernel-internals lists math
namespaces prettyprint sequences strings vectors words ;
! A Factor interpreter written in Factor. Used by compiler for
! partial evaluation, also by the walker.
@ -14,8 +14,6 @@ SYMBOL: meta-r
SYMBOL: meta-d
: push-d meta-d get push ;
: pop-d meta-d get pop ;
: peek-d meta-d get peek ;
: peek-next-d meta-d get [ length 2 - ] keep nth ;
SYMBOL: meta-n
SYMBOL: meta-c
@ -66,7 +64,9 @@ SYMBOL: meta-executing
[ meta-executing get push-r push-r ] when*
] change ;
: meta-word ( word -- )
GENERIC: do ( obj -- )
M: word do ( word -- )
dup "meta-word" word-prop [
call
] [
@ -77,12 +77,18 @@ SYMBOL: meta-executing
] ifte
] ?ifte ;
: do ( obj -- ) dup word? [ meta-word ] [ push-d ] ifte ;
M: wrapper do ( wrapper -- ) wrapped push-d ;
: meta-word-1 ( word -- )
M: object do ( object -- ) push-d ;
GENERIC: do-1 ( object -- )
M: word do-1 ( word -- )
dup "meta-word" word-prop [ call ] [ host-word ] ?ifte ;
: do-1 ( obj -- ) dup word? [ meta-word-1 ] [ push-d ] ifte ;
M: wrapper do-1 ( wrapper -- ) wrapped push-d ;
M: object do-1 ( object -- ) push-d ;
: set-meta-word ( word quot -- ) "meta-word" set-word-prop ;
@ -93,7 +99,7 @@ SYMBOL: meta-executing
\ callstack [ meta-r get clone push-d ] set-meta-word
\ set-callstack [ pop-d clone meta-r set ] set-meta-word
\ call [ pop-d meta-call ] set-meta-word
\ execute [ pop-d meta-word ] set-meta-word
\ execute [ pop-d do ] set-meta-word
\ ifte [ pop-d pop-d pop-d [ nip ] [ drop ] ifte meta-call ] set-meta-word
\ dispatch [ pop-d pop-d swap nth meta-call ] set-meta-word

2
library/ui/presentations.factor
View File

@ -15,7 +15,7 @@ global [ 100 <vector> commands set ] bind
commands get [ first call ] subset-with ;
: command-quot ( presented quot -- quot )
[ swap literal, % ] make-list
[ swap literalize , % ] make-list
[ pane get pane-call drop ] cons ;
: command-menu ( presented -- menu )

10
library/words.factor
View File

@ -122,6 +122,10 @@ M: compound definer drop \ : ;
over f "dispatcher" set-word-prop
(define-compound) ;
: literalize ( word/obj -- quot )
#! Produce a quotation that pushes this object.
dup word? [ unit [ car ] ] [ f ] ifte cons ;
GENERIC: literalize ( obj -- obj )
M: object literalize ;
M: word literalize <wrapper> ;
M: wrapper literalize <wrapper> ;

1
native/factor.h
View File

@ -131,6 +131,7 @@ typedef unsigned char BYTE;
#include "relocate.h"
#include "alien.h"
#include "dll.h"
#include "wrapper.h"
#include "debug.h"
#endif /* __FACTOR_H__ */

3
native/gc.c
View File

@ -179,6 +179,9 @@ INLINE void collect_object(CELL scan)
case DISPLACED_ALIEN_TYPE:
collect_displaced_alien((DISPLACED_ALIEN*)scan);
break;
case WRAPPER_TYPE:
collect_wrapper((F_WRAPPER*)scan);
break;
}
}

3
native/memory.c
View File

@ -81,6 +81,9 @@ CELL untagged_object_size(CELL pointer)
case DISPLACED_ALIEN_TYPE:
size = sizeof(DISPLACED_ALIEN);
break;
case WRAPPER_TYPE:
size = sizeof(F_WRAPPER);
break;
default:
critical_error("Cannot determine untagged_object_size",pointer);
size = -1;/* can't happen */

1
native/memory.h
View File

@ -69,6 +69,7 @@ CELL T;
#define STRING_TYPE 12
#define SBUF_TYPE 13
#define DLL_TYPE 15
#define WRAPPER_TYPE 14
#define ALIEN_TYPE 16
#define WORD_TYPE 17
#define TUPLE_TYPE 18

3
native/primitives.c
View File

@ -172,7 +172,8 @@ void* primitives[] = {
primitive_fwrite,
primitive_fflush,
primitive_fclose,
primitive_expired
primitive_expired,
primitive_wrapper
};
CELL primitive_to_xt(CELL primitive)

3
native/relocate.c
View File

@ -32,6 +32,9 @@ void relocate_object(CELL relocating)
case DISPLACED_ALIEN_TYPE:
fixup_displaced_alien((DISPLACED_ALIEN*)relocating);
break;
case WRAPPER_TYPE:
fixup_wrapper((F_WRAPPER*)relocating);
break;
}
}

12
native/run.c
View File

@ -50,10 +50,18 @@ void run(void)
next = get(callframe);
callframe = get(callframe + CELLS);
if(type_of(next) == WORD_TYPE)
switch(type_of(next))
{
case WORD_TYPE:
execute(untag_word_fast(next));
else
break;
case WRAPPER_TYPE:
dpush(untag_wrapper_fast(next)->object);
break;
default:
dpush(next);
break;
}
}
}

22
native/wrapper.c Normal file
View File

@ -0,0 +1,22 @@
#include "factor.h"
void primitive_wrapper(void)
{
F_WRAPPER* wrapper;
maybe_gc(sizeof(F_WRAPPER));
wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
drepl(tag_object(wrapper));
}
void fixup_wrapper(F_WRAPPER* wrapper)
{
data_fixup(&wrapper->object);
}
void collect_wrapper(F_WRAPPER* wrapper)
{
copy_handle(&wrapper->object);
}

13
native/wrapper.h Normal file
View File

@ -0,0 +1,13 @@
typedef struct {
CELL header;
CELL object;
} F_WRAPPER;
INLINE F_WRAPPER* untag_wrapper_fast(CELL tagged)
{
return (F_WRAPPER*)UNTAG(tagged);
}
void primitive_wrapper(void);
void fixup_wrapper(F_WRAPPER* wrapper);
void collect_wrapper(F_WRAPPER* wrapper);