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

More quotation work

slava 2006-05-16 20:50:51 +00:00
parent 3ff4bef040
commit 9b286735ea
15 changed files with 112 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
doc/handbook/objects.facts
View File

@ -33,25 +33,25 @@ $terpri
{ $subsection POSTPONE: GENERIC: }
{ $subsection POSTPONE: M: }
"Since classes are not linearly ordered, method ordering is an issue to keep in mind."
{ $subsection "method-order" }
! { $subsection "method-order" }
{ $subsection "method-combination" } ;
ARTICLE: "method-order" "Method ordering"
"If two classes have a non-empty intersection, there is no guarantee that one is a subclass of the other. This means there is no canonical linear ordering of classes."
$terpri
"Consider the following set of definitions:"
{ $code
"GENERIC: explain"
"M: general-t explain drop \"a true value\" print ;"
"M: general-list explain drop \"a list\" print ;"
"M: object explain drop \"an object\" print ;"
}
"Neither " { $link general-t } " nor " { $link general-list } " contains the other, yet their intersection is the non-empty " { $link cons } " class. So the generic word system will place " { $link object } " first in the method order, however either " { $link general-t } " or " { $link general-list } " may come next, and it is pretty much a random choice that depends on hashing:"
{ $example "\\ bar order ." "{ object general-list general-t }" }
"Therefore, the outcome of calling " { $snippet "bar" } " with a cons cell as input is undefined."
$terpri
"As you can see above, the " { $link order } " word can be useful to clarify method dispatch."
{ $subsection order } ;
! ARTICLE: "method-order" "Method ordering"
! "If two classes have a non-empty intersection, there is no guarantee that one is a subclass of the other. This means there is no canonical linear ordering of classes."
! $terpri
! "Consider the following set of definitions:"
! { $code
! "GENERIC: explain"
! "M: general-t explain drop \"a true value\" print ;"
! "M: explain drop \"a list\" print ;"
! "M: object explain drop \"an object\" print ;"
! }
! "Neither " { $link general-t } " nor " { $link general-list } " contains the other, yet their intersection is the non-empty " { $link cons } " class. So the generic word system will place " { $link object } " first in the method order, however either " { $link general-t } " or " { $link general-list } " may come next, and it is pretty much a random choice that depends on hashing:"
! { $example "\\ bar order ." "{ object general-list general-t }" }
! "Therefore, the outcome of calling " { $snippet "bar" } " with a cons cell as input is undefined."
! $terpri
! "As you can see above, the " { $link order } " word can be useful to clarify method dispatch."
! { $subsection order } ;
GLOSSARY: "method combination" "control flow glue between methods in a generic word" ;

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

@ -51,7 +51,6 @@ vectors words ;
"/library/collections/sequence-eq.factor"
"/library/collections/slicing.factor"
"/library/collections/sequence-sort.factor"
"/library/collections/lists.factor"
"/library/collections/flatten.factor"
"/library/collections/queues.factor"
"/library/collections/graphs.factor"

16
library/bootstrap/image.factor
View File

@ -33,7 +33,8 @@ IN: image
: wrapper-type 14 ; inline
: word-type 16 ; inline
: tuple-type 17 ; inline
: byte-array-type 18 ; inline
: quotation-type 19 ; inline
: base 1024 ;
@ -204,12 +205,7 @@ M: word ' ( word -- pointer ) ;
M: wrapper ' ( wrapper -- pointer )
wrapped ' wrapper-type object-tag [ emit ] emit-object ;
( Conses )
: emit-cons ( first second tag -- pointer )
>r ' swap ' r> here-as -rot emit emit ;
M: cons ' ( c -- tagged ) uncons cons-tag emit-cons ;
( Ratios and complexes )
: emit-pair
[ [ emit ] 2apply ] emit-object ;
@ -261,6 +257,12 @@ M: tuple ' ( tuple -- pointer )
M: array ' ( array -- pointer )
array-type emit-array ;
! M: quotation ' ( array -- pointer )
! quotation-type emit-array ;
M: cons ' ( c -- tagged )
objects get [ quotation-type emit-array ] cache ;
M: vector ' ( vector -- pointer )
dup underlying ' swap length
vector-type object-tag [

1
library/bootstrap/primitives.factor
View File

@ -227,6 +227,7 @@ call
{ "tuple>array" "generic" }
{ "array>vector" "vectors" }
{ "<string>" "strings" }
{ "<quotation>" "kernel" }
} dup length 3 swap [ + ] map-with [ make-primitive ] 2each
FORGET: make-primitive

5
library/collections/arrays.facts
View File

@ -1,5 +1,6 @@
IN: arrays
USING: help kernel-internals lists prettyprint strings vectors ;
USING: help kernel kernel-internals lists prettyprint strings
vectors ;
HELP: <array> "( n elt -- array )"
{ $values { "n" "a positive integer specifying array length" } { "elt" "an initial element" } }
@ -9,7 +10,7 @@ HELP: <array> "( n elt -- array )"
HELP: >array "( seq -- array )"
{ $values { "seq" "a sequence" } { "array" "an array" } }
{ $description "Outputs a freshly-allocated array with the same elements as a given sequence." }
{ $see-also >string >sbuf >vector >list } ;
{ $see-also >string >sbuf >vector >quotation } ;
HELP: 1array "( x -- array )"
{ $values { "x" "an object" } { "array" "an array" } }

4
library/collections/flatten.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sequences
USING: generic kernel lists namespaces strings ;
USING: generic kernel namespaces strings ;
GENERIC: flatten* ( obj -- )
@ -13,8 +13,6 @@ M: string flatten* , ;
M: sbuf flatten* , ;
M: cons flatten* uncons >r flatten* r> flatten* ;
M: wrapper flatten* wrapped flatten* ;
: flatten ( obj -- seq ) [ flatten* ] { } make ;

80
library/collections/lists.factor
View File

@ -1,80 +0,0 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: lists USING: arrays errors generic kernel math sequences ;
M: f car ;
M: f cdr ;
UNION: general-list POSTPONE: f cons ;
GENERIC: >list ( seq -- list )
M: general-list >list ( list -- list ) ;
PREDICATE: general-list list ( list -- ? )
#! Proper list test. A proper list is either f, or a cons
#! cell whose cdr is a proper list.
[ cdr list? ] [ t ] if* ;
: uncons ( [[ car cdr ]] -- car cdr ) dup car swap cdr ; inline
: 2car ( cons cons -- car car ) [ car ] 2apply ; inline
: 2cdr ( cons cons -- car car ) [ cdr ] 2apply ; inline
! Sequence protocol
M: f length drop 0 ;
M: cons length cdr length 1+ ;
: (list-each) ( list quot -- )
over [
[ >r car r> call ] 2keep >r cdr r> (list-each)
] [
2drop
] if ; inline
M: general-list each ( list quot -- | quot: elt -- )
(list-each) ;
: (list-map) ( list quot -- list )
over [
over cdr over >r >r >r car r> call
r> r> rot >r (list-map) r> swap cons
] [
drop
] if ; inline
M: general-list map ( list quot -- list ) (list-map) ;
: (list-find) ( list quot i -- i elt )
pick [
>r 2dup >r >r >r car r> call [
r> car r> drop r> swap
] [
r> cdr r> r> 1+ (list-find)
] if
] [
3drop -1 f
] if ; inline
M: general-list find ( list quot -- i elt )
0 (list-find) ;
M: general-list nth ( n list -- element )
over 0 <= [ nip car ] [ >r 1- r> cdr nth ] if ;
M: cons = ( obj cons -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over cons? not ] [ 2drop f ] }
{ [ t ] [ 2dup 2car = >r 2cdr = r> and ] }
} cond ;
: (>list) ( n i seq -- list )
pick pick <= [
3drop [ ]
] [
2dup nth >r >r 1+ r> (>list) r> swap cons
] if ;
M: object >list ( seq -- list ) dup length 0 rot (>list) ;
M: general-list like drop >list ;

4
library/collections/strings.facts
View File

@ -1,4 +1,4 @@
USING: arrays help lists strings vectors ;
USING: arrays help kernel lists strings vectors ;
HELP: <string> "( n ch -- string )"
{ $values { "n" "a positive integer specifying string length" } { "elt" "an initial character" } }
@ -71,4 +71,4 @@ HELP: >string "( seq -- str )"
{ $values { "seq" "a sequence of characters" } { "str" "a new string" } }
{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than real numbers." }
{ $see-also >array >sbuf >vector >list } ;
{ $see-also >array >sbuf >vector >quotation } ;

3
library/compiler/inference/known-words.factor
View File

@ -512,3 +512,6 @@ sequences strings vectors words prettyprint ;
\ <string> [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
\ <string> t "flushable" set-word-prop
\ <quotation> [ [ integer ] [ quotation ] ] "infer-effect" set-word-prop
\ <quotation> t "flushable" set-word-prop

28
library/quotations.factor
View File

@ -1,31 +1,27 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: kernel
USING: arrays kernel-internals lists math namespaces sequences
USING: arrays kernel-internals math namespaces sequences
sequences-internals ;
UNION: quotation general-list ;
M: quotation clone (clone) ;
M: quotation length array-capacity ;
M: quotation nth bounds-check nth-unsafe ;
M: quotation set-nth bounds-check set-nth-unsafe ;
M: quotation nth-unsafe >r >fixnum r> array-nth ;
M: quotation set-nth-unsafe >r >fixnum r> set-array-nth ;
M: quotation resize resize-array ;
: >quotation >list ;
: >quotation ( seq -- array ) [ <quotation> ] >sequence ; inline
M: quotation like drop dup quotation? [ >quotation ] unless ;
: make-dip ( quot n -- quot )
dup \ >r <array> -rot \ r> <array> append3 >quotation ;
: unit ( a -- [ a ] ) 1array >quotation ;
: curry ( obj quot -- quot ) >r unit r> append ;
: curry ( obj quot -- quot ) >r literalize unit r> append ;
: alist>quot ( default alist -- quot )
[ [ first2 swap % , , \ if , ] [ ] make ] each ;
! M: quotation clone (clone) ;
! M: quotation length array-capacity ;
! M: quotation nth bounds-check nth-unsafe ;
! M: quotation set-nth bounds-check set-nth-unsafe ;
! M: quotation nth-unsafe >r >fixnum r> array-nth ;
! M: quotation set-nth-unsafe >r >fixnum r> set-array-nth ;
! M: quotation resize resize-array ;
!
! : >quotation ( seq -- array ) [ <quotation> ] >sequence ; inline
!
! M: quotation like drop dup quotation? [ >quotation ] unless ;

6
library/tools/interpreter.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: interpreter
USING: errors generic io kernel kernel-internals lists math
USING: errors generic io kernel kernel-internals math
namespaces prettyprint sequences strings vectors words ;
! A Factor interpreter written in Factor. It can transfer the
@ -34,7 +34,7 @@ SYMBOL: meta-executing
: up ( -- ) pop-c meta-cf set pop-c drop ;
: next ( -- obj )
meta-cf get [ meta-cf [ uncons ] change ] [ up next ] if ;
meta-cf get [ meta-cf [ ( uncons ) ] change ] [ up next ] if ;
: meta-interp ( -- interp )
meta-d get meta-r get meta-c get
@ -51,7 +51,7 @@ SYMBOL: meta-executing
: host-word ( word -- )
[
\ call push-c
[ continuation swap continue-with ] cons cons push-c
[ continuation swap continue-with ] ( cons cons ) push-c
meta-interp continue
] callcc1 set-meta-interp pop-d 2drop ;

41
native/array.c
View File

@ -42,6 +42,31 @@ void primitive_array(void)
dpush(tag_object(array(ARRAY_TYPE,size,initial)));
}
/* push a new tuple on the stack */
void primitive_tuple(void)
{
F_FIXNUM size = to_fixnum(dpop());
maybe_gc(array_size(size));
dpush(tag_object(array(TUPLE_TYPE,size,F)));
}
/* push a new byte on the stack */
void primitive_byte_array(void)
{
F_FIXNUM size = to_fixnum(dpop());
maybe_gc(0);
dpush(tag_object(byte_array(size)));
}
/* push a new quotation on the stack */
void primitive_quotation(void)
{
F_FIXNUM size;
maybe_gc(0);
size = to_fixnum(dpop());
dpush(tag_object(array(QUOTATION_TYPE,size,F)));
}
CELL make_array_2(CELL v1, CELL v2)
{
F_ARRAY *a = array(ARRAY_TYPE,2,F);
@ -60,22 +85,6 @@ CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
return tag_object(a);
}
/* push a new tuple on the stack */
void primitive_tuple(void)
{
F_FIXNUM size = to_fixnum(dpop());
maybe_gc(array_size(size));
dpush(tag_object(array(TUPLE_TYPE,size,F)));
}
/* push a new byte on the stack */
void primitive_byte_array(void)
{
F_FIXNUM size = to_fixnum(dpop());
maybe_gc(0);
dpush(tag_object(byte_array(size)));
}
F_ARRAY* resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
{
int i;

1
native/array.h
View File

@ -35,6 +35,7 @@ CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
void primitive_array(void);
void primitive_tuple(void);
void primitive_byte_array(void);
void primitive_quotation(void);
F_ARRAY *resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill);
void primitive_resize_array(void);

36
native/debug.c
View File

@ -42,11 +42,20 @@ void print_string(F_STRING* str)
fprintf(stderr,"\"");
}
void print_array(F_ARRAY* array)
{
CELL length = array_capacity(array);
CELL i;
for(i = 0; i < length; i++)
{
fprintf(stderr," ");
print_obj(get(AREF(array,i)));
}
}
void print_obj(CELL obj)
{
F_ARRAY *array;
CELL class;
switch(type_of(obj))
{
case FIXNUM_TYPE:
@ -65,14 +74,19 @@ void print_obj(CELL obj)
fprintf(stderr,"f");
break;
case TUPLE_TYPE:
array = (F_ARRAY*)UNTAG(obj);
fprintf(stderr,"<< ");
class = get(AREF(array,0));
if(type_of(class) == WORD_TYPE)
print_word(untag_word(class));
else
fprintf(stderr," corrupt tuple: %lx ",class);
fprintf(stderr," %lx >>",obj);
fprintf(stderr,"T{");
print_array((F_ARRAY*)UNTAG(obj));
fprintf(stderr," }");
break;
case ARRAY_TYPE:
fprintf(stderr,"{");
print_array((F_ARRAY*)UNTAG(obj));
fprintf(stderr," }");
break;
case QUOTATION_TYPE:
fprintf(stderr,"[");
print_array((F_ARRAY*)UNTAG(obj));
fprintf(stderr," ]");
break;
default:
fprintf(stderr,"#<type %ld @ %lx>",type_of(obj),obj);

3
native/primitives.c
View File

@ -190,7 +190,8 @@ void* primitives[] = {
primitive_array_to_tuple,
primitive_tuple_to_array,
primitive_array_to_vector,
primitive_string
primitive_string,
primitive_quotation
};
CELL primitive_to_xt(CELL primitive)