diff --git a/doc/handbook/objects.facts b/doc/handbook/objects.facts index 6fe1baebf4..d065ae6122 100644 --- a/doc/handbook/objects.facts +++ b/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" -"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" ; diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index f3530202e1..4dafd01cad 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/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" diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 034a5c1c21..41a7761129 100644 --- a/library/bootstrap/image.factor +++ b/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 -: hashtable-type 10 ; inline -: vector-type 11 ; inline -: string-type 12 ; inline -: sbuf-type 13 ; inline -: wrapper-type 14 ; inline -: word-type 16 ; inline -: tuple-type 17 ; inline - +: array-type 8 ; inline +: hashtable-type 10 ; inline +: vector-type 11 ; inline +: string-type 12 ; inline +: sbuf-type 13 ; inline +: 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 [ diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 9aded34f6e..9e76e44708 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -227,6 +227,7 @@ call { "tuple>array" "generic" } { "array>vector" "vectors" } { "" "strings" } + { "" "kernel" } } dup length 3 swap [ + ] map-with [ make-primitive ] 2each FORGET: make-primitive diff --git a/library/collections/arrays.facts b/library/collections/arrays.facts index 8f21b0eaca..34a249e8ac 100644 --- a/library/collections/arrays.facts +++ b/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: "( n elt -- array )" { $values { "n" "a positive integer specifying array length" } { "elt" "an initial element" } } @@ -9,7 +10,7 @@ HELP: "( 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" } } diff --git a/library/collections/flatten.factor b/library/collections/flatten.factor index 55ddbb7338..38940d690c 100644 --- a/library/collections/flatten.factor +++ b/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 ; diff --git a/library/collections/lists.factor b/library/collections/lists.factor deleted file mode 100644 index d52fbabd02..0000000000 --- a/library/collections/lists.factor +++ /dev/null @@ -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 ; diff --git a/library/collections/strings.facts b/library/collections/strings.facts index 625d11f6cf..9186dc9348 100644 --- a/library/collections/strings.facts +++ b/library/collections/strings.facts @@ -1,4 +1,4 @@ -USING: arrays help lists strings vectors ; +USING: arrays help kernel lists strings vectors ; HELP: "( 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 } ; diff --git a/library/compiler/inference/known-words.factor b/library/compiler/inference/known-words.factor index 5f0ef47e48..4175ac5070 100644 --- a/library/compiler/inference/known-words.factor +++ b/library/compiler/inference/known-words.factor @@ -512,3 +512,6 @@ sequences strings vectors words prettyprint ; \ [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop \ t "flushable" set-word-prop + +\ [ [ integer ] [ quotation ] ] "infer-effect" set-word-prop +\ t "flushable" set-word-prop diff --git a/library/quotations.factor b/library/quotations.factor index 14460a8aa9..715813a5de 100644 --- a/library/quotations.factor +++ b/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 ) [ ] >sequence ; inline + +M: quotation like drop dup quotation? [ >quotation ] unless ; : make-dip ( quot n -- quot ) dup \ >r -rot \ r> 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 ) [ ] >sequence ; inline -! -! M: quotation like drop dup quotation? [ >quotation ] unless ; diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 846eb81053..abdb81de53 100644 --- a/library/tools/interpreter.factor +++ b/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 ; diff --git a/native/array.c b/native/array.c index 94cd9fe683..7da825598d 100644 --- a/native/array.c +++ b/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; diff --git a/native/array.h b/native/array.h index ff8406ca2a..345f34f9be 100644 --- a/native/array.h +++ b/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); diff --git a/native/debug.c b/native/debug.c index d15a100307..89719fea33 100644 --- a/native/debug.c +++ b/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,"<< "); - 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_of(obj),obj); diff --git a/native/primitives.c b/native/primitives.c index ed3a37da61..d87cde74bd 100644 --- a/native/primitives.c +++ b/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)