More quotation work

doc/handbook/objects.facts

@@ -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"
+! 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."
+! "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
+! $terpri
-"Consider the following set of definitions:"
+! "Consider the following set of definitions:"
-{ $code
+! { $code
-    "GENERIC: explain"
+!     "GENERIC: explain"
-    "M: general-t explain drop \"a true value\" print ;"
+!     "M: general-t explain drop \"a true value\" print ;"
-    "M: general-list explain drop \"a list\" print ;"
+!     "M:  explain drop \"a list\" print ;"
-    "M: object explain drop \"an object\" 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:"
+! "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 }" }
+! { $example "\\ bar order ."  "{ object general-list general-t }" }
-"Therefore, the outcome of calling " { $snippet "bar" } " with a cons cell as input is undefined."
+! "Therefore, the outcome of calling " { $snippet "bar" } " with a cons cell as input is undefined."
-$terpri
+! $terpri
-"As you can see above, the " { $link order } " word can be useful to clarify method dispatch."
+! "As you can see above, the " { $link order } " word can be useful to clarify method dispatch."
-{ $subsection order } ;
+! { $subsection order } ;
 
 GLOSSARY: "method combination" "control flow glue between methods in a generic word" ;
 

library/bootstrap/boot-stage1.factor

@@ -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"

library/bootstrap/image.factor

@@ -25,15 +25,16 @@ IN: image
 : untag ( cell tag -- ) tag-mask bitnot bitand ; inline
 : tag ( cell -- tag ) tag-mask bitand ; inline
 
-: array-type     8  ; inline
+: array-type      8  ; inline
-: hashtable-type 10 ; inline
+: hashtable-type  10 ; inline
-: vector-type    11 ; inline
+: vector-type     11 ; inline
-: string-type    12 ; inline
+: string-type     12 ; inline
-: sbuf-type      13 ; inline
+: sbuf-type       13 ; inline
-: wrapper-type   14 ; inline
+: wrapper-type    14 ; inline
-: word-type      16 ; inline
+: word-type       16 ; inline
-: tuple-type     17 ; 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 )
+( Ratios and complexes )
-
-: emit-cons ( first second tag -- pointer )
-    >r ' swap ' r> here-as -rot emit emit ;
-
-M: cons ' ( c -- tagged ) uncons cons-tag emit-cons ;
 
 : 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 [

library/bootstrap/primitives.factor

@@ -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

library/collections/arrays.facts

@@ -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" } }

library/collections/flatten.factor

@@ -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 ;

library/collections/lists.factor

@@ -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 ;

library/collections/strings.facts

@@ -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 } ;

library/compiler/inference/known-words.factor

@@ -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

library/quotations.factor

@@ -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 ;

library/tools/interpreter.factor

@@ -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 ;
 

native/array.c

@@ -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;

native/array.h

@@ -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);

native/debug.c

@@ -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,"T{");
-		fprintf(stderr,"<< ");
+		print_array((F_ARRAY*)UNTAG(obj));
-		class = get(AREF(array,0));
+		fprintf(stderr," }");
-		if(type_of(class) == WORD_TYPE)
+		break;
-			print_word(untag_word(class));
+	case ARRAY_TYPE:
-		else
+		fprintf(stderr,"{");
-			fprintf(stderr," corrupt tuple: %lx ",class);
+		print_array((F_ARRAY*)UNTAG(obj));
-		fprintf(stderr," %lx >>",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);

native/primitives.c

@@ -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)