Merge branch 'master' of git://factorcode.org/git/factor

extra/bake/bake.factor

@@ -1,61 +1,59 @@
 
-USING: kernel parser namespaces quotations arrays vectors strings
+USING: kernel parser combinators sequences splitting quotations arrays macros
-       sequences assocs classes.tuple math combinators ;
+       arrays.lib combinators.cleave combinators.conditional newfx ;
 
 IN: bake
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-TUPLE: insert-quot expr ;
+SYMBOL: ,
+SYMBOL: @
 
-C: <insert-quot> insert-quot 
+: comma? ( obj -- ? ) , = ;
-
+: atsym? ( obj -- ? ) @ = ;
-: ,[ \ ] [ >quotation <insert-quot> ] parse-literal ; parsing
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-TUPLE: splice-quot expr ;
+DEFER: [bake-array]
 
-C: <splice-quot> splice-quot
+: broil-element ( obj -- quot )
-
+    {
-: %[ \ ] [ >quotation <splice-quot> ] parse-literal ; parsing
+      { [ comma? ] [ drop [ >r ]               ] }
+      { [ array? ] [ [bake-array] [ >r ] append ] }
+      { [ drop t ] [ [ >r ] prefix-on          ] }
+    }
+  1cond ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: ,u ( seq -- seq ) unclip building get push ;
+: [broil] ( array -- quot )
+    [ reverse [ broil-element ] map concat ]
+    [ length [ drop [ r> ] ] map concat ]
+    [ length [ narray ] prefix-on ]
+  tri append append
+  >quotation ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOL: exemplar
+: [simmer] ( array -- quot )
 
-: reset-building ( -- ) 1024 <vector> building set ;
+  { @ } split reverse
+    [        [ [bake-array] [ append ] append [ >r ] append ] map concat ]
+    [ length [ drop [ r> append ]                          ] map concat ]
+  bi
 
-: save-exemplar ( seq -- seq ) dup exemplar set ;
+  >r 2 head* [ >r ] append r> ! remove the last append
 
-: finish-baking ( -- seq ) building get exemplar get like ;
+  [ { } ] swap append
 
-DEFER: bake
+  append ;
-
-: bake-item ( item -- )
-  { { [ dup \ , = ]        [ drop , ] }
-    { [ dup \ % = ]        [ drop % ] }
-    { [ dup \ ,u = ]       [ drop ,u ] }
-    { [ dup insert-quot? ] [ insert-quot-expr call , ] }
-    { [ dup splice-quot? ] [ splice-quot-expr call % ] }
-    { [ dup integer? ]     [ , ] }
-    { [ dup string? ]      [ , ] }
-    { [ dup tuple? ]       [ tuple>array bake >tuple , ] }
-    { [ dup assoc? ]       [ [ >alist bake ] keep assoc-like , ] }
-    { [ dup sequence? ]    [ bake , ] }
-    { [ t ]                [ , ] } }
-  cond ;
-
-: bake-items ( seq -- ) [ bake-item ] each ;
-
-: bake ( seq -- seq )
-  [ reset-building save-exemplar bake-items finish-baking ] with-scope ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
+: [bake-array] ( array -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
 
+MACRO: bake-array ( array -- quot ) [bake-array] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing

extra/bootstrap/image/download/download.factor

@@ -1,13 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: bootstrap.image.download
 USING: http.client checksums checksums.openssl splitting assocs
-kernel io.files bootstrap.image sequences io ;
+kernel io.files bootstrap.image sequences io urls ;
+IN: bootstrap.image.download
 
-: url "http://factorcode.org/images/latest/" ;
+: url URL" http://factorcode.org/images/latest/" ;
 
 : download-checksums ( -- alist )
-    url "checksums.txt" append http-get nip
+    url "checksums.txt" >url derive-url http-get nip
     string-lines [ " " split1 ] { } map>assoc ;
 
 : need-new-image? ( image -- ? )
@@ -21,7 +21,10 @@ kernel io.files bootstrap.image sequences io ;
 : download-image ( arch -- )
     boot-image-name dup need-new-image? [
         "Downloading " write dup write "..." print
-        url prepend download
+         url over >url derive-url download
+         need-new-image? [
+             "Boot image corrupt, or checksums.txt on server out of date" throw
+         ] when
     ] [
         "Boot image up to date" print
         drop

extra/builder/release/release.factor

@@ -1,7 +1,7 @@
 
 USING: kernel debugger system namespaces sequences splitting combinators
        io io.files io.launcher prettyprint bootstrap.image
-       bake combinators.cleave
+       combinators.cleave
        builder.util
        builder.common
        builder.release.branch

extra/builder/util/util.factor

@@ -6,7 +6,7 @@ USING: kernel words namespaces classes parser continuations
        combinators sequences splitting quotations arrays strings tools.time
        sequences.deep accessors assocs.lib
        io.encodings.utf8
-       combinators.cleave bake calendar calendar.format ;
+       combinators.cleave calendar calendar.format ;
 
 IN: builder.util
 

extra/combinators/conditional/conditional.factor

@@ -0,0 +1,17 @@
+
+USING: kernel combinators sequences macros fry newfx combinators.cleave ;
+
+IN: combinators.conditional
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: 1cond ( tbl -- )
+  [ [ 1st [ dup ] prepend ] [ 2nd ] bi {2} ] map
+  [ cond ] prefix-on ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/newfx/newfx.factor

@@ -196,3 +196,26 @@ METHOD: as-mutate { object object assoc }       set-at ;
 : adjoin-on   ( elt seq -- seq ) tuck sets:adjoin ;
 : adjoined    ( set elt --     ) swap sets:adjoin ;
 : adjoined-on ( elt set --     )      sets:adjoin ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start ( seq subseq -- i ) swap sequences:start ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pluck         ( seq i   -- seq ) cut-slice rest-slice append ;
+: pluck-from    ( i   seq -- seq ) swap pluck ;
+: pluck!        ( seq i   -- seq ) over delete-nth ;
+: pluck-from!   ( i   seq -- seq ) tuck delete-nth ;
+: plucked!      ( seq i   --     ) swap delete-nth ;
+: plucked-from! ( i   seq --     )      delete-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: snip          ( seq a b -- seq ) >r over r> [ head ] [ tail ] 2bi* append ;
+: snip-this     ( a b seq -- seq ) -rot snip ;
+: snip!         ( seq a b -- seq )      pick delete-slice ;
+: snip-this!    ( a b seq -- seq ) -rot pick delete-slice ;
+: snipped!      ( seq a b --     )       rot delete-slice ;
+: snipped-from! ( a b seq --     )           delete-slice ;
+

extra/random-weighted/random-weighted.factor

@@ -1,6 +1,6 @@
 
 USING: kernel namespaces arrays quotations sequences assocs combinators
-       mirrors math math.vectors random macros bake ;
+       mirrors math math.vectors random macros fry ;
 
 IN: random-weighted
 
@@ -16,5 +16,5 @@ probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
 dup [ second ] map swap [ first ] map random-weighted swap nth ;
 
 MACRO: call-random-weighted ( exp -- )
-  [ keys ] [ values <enum> >alist ] bi swap
+  [ keys ] [ values <enum> >alist ] bi
-  [ , random-weighted , case ] bake ;
+  '[ , random-weighted , case ] ;

extra/raptor/raptor.factor

@@ -1,5 +1,6 @@
 
-USING: kernel parser namespaces threads arrays sequences unix unix.process bake ;
+USING: kernel parser namespaces threads arrays sequences unix unix.process
+       bake ;
 
 IN: raptor
 

extra/rewrite-closures/rewrite-closures.factor

@@ -1,30 +1,26 @@
 
-USING: kernel parser math quotations namespaces sequences namespaces.lib 
+USING: kernel parser math quotations namespaces sequences macros fry ;
-       inference.transforms ;
 
 IN: rewrite-closures
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! : set-parameters ( seq -- ) reverse [ set ] each ;
+: [set-parameters] ( seq -- quot ) reverse [ [ set ] curry ] map concat ;
 
-: [set-parameters] ( seq -- quot ) [ [ set ] curry ] map concat ;
+MACRO: set-parameters ( seq -- quot ) [set-parameters] ;
-
-: set-parameters ( seq -- ) [set-parameters] call ;
-
-\ set-parameters [ [set-parameters] ] 1 define-transform
-
-: parametric-quot ( parameters quot -- quot )
-[ [ swap ] set-parameters [ ] call ] make* ;
-
-: scoped-quot ( quot -- quot ) [ with-scope ] curry ;
-
-: closed-quot ( quot -- quot )
-[ namestack >r [ namestack ] set-namestack [ ] call r> set-namestack ] make* ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: lambda ( parameters quot -- ) parametric-quot scoped-quot closed-quot ;
+: parametric-quot ( parameters quot -- quot ) '[ , set-parameters , call ] ;
+
+: scoped-quot ( quot -- quot ) '[ , with-scope ] ;
+
+: closed-quot ( quot -- quot )
+  namestack swap '[ namestack [ , set-namestack @ ] dip set-namestack ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: lambda ( parameters quot -- quot ) parametric-quot scoped-quot closed-quot ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/size-of/size-of.factor

@@ -12,15 +12,15 @@ IN: size-of
 VAR: headers
 
 : include-headers ( -- seq )
-  headers> [ { "#include <" , ">" } bake to-string ] map ;
+  headers> [ `{ "#include <" , ">" } to-string ] map ;
 
 : size-of-c-program ( type -- lines )
-  {
+  `{
     "#include <stdio.h>"
     include-headers
     { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" }
   }
-  bake to-strings ;
+  to-strings ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/springies/models/2x2snake/2x2snake.factor

@@ -1,6 +1,6 @@
 
 USING: kernel namespaces arrays sequences threads math math.vectors
-       ui random bake springies springies.ui ;
+       ui random springies springies.ui ;
 
 IN: springies.models.2x2snake
 

extra/springies/models/3snake/3snake.factor

@@ -1,5 +1,5 @@
 
-USING: kernel namespaces arrays sequences threads math ui random bake
+USING: kernel namespaces arrays sequences threads math ui random fry
        springies springies.ui ;
 
 IN: springies.models.3snake
@@ -158,8 +158,10 @@ times
 
 ;
 
-: go* ( quot -- )
+! : go* ( quot -- )
-  [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ;
+!   [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ;
+
+: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
 
 ! : go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
 

extra/springies/models/belt-tire/belt-tire.factor

@@ -1,5 +1,5 @@
 
-USING: kernel namespaces arrays sequences threads math ui random bake
+USING: kernel namespaces arrays sequences threads math ui random
        springies springies.ui ;
 
 IN: springies.models.belt-tire

extra/springies/models/nifty/nifty.factor

@@ -1,6 +1,6 @@
 
 USING: kernel namespaces arrays sequences threads math math.vectors
-       ui random bake springies springies.ui ;
+       ui random springies springies.ui ;
 
 IN: springies.models.nifty
 

extra/springies/models/urchin/urchin.factor

@@ -1,6 +1,6 @@
 
 USING: kernel namespaces arrays sequences threads math math.vectors
-       ui random bake
+       ui random
        springies springies.ui ;
 
 IN: springies.models.urchin

extra/springies/ui/ui.factor

@@ -1,7 +1,7 @@
 
 USING: kernel namespaces threads sequences math math.vectors
        opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
-       bake rewrite-closures vars springies ;
+       fry rewrite-closures vars springies ;
 
 IN: springies.ui
 
@@ -62,5 +62,4 @@ DEFER: maybe-loop
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: go* ( quot -- )
+: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
-  [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ;

vm/image.c

@@ -28,8 +28,14 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
 
 	F_ZONE *tenured = &data_heap->generations[TENURED];
 
-	if(fread((void*)tenured->start,h->data_size,1,file) != 1)
+	long int bytes_read = fread((void*)tenured->start,1,h->data_size,file);
+
+	if(bytes_read != h->data_size)
+	{
+		fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n",
+			bytes_read,h->data_size);
 		fatal_error("load_data_heap failed",0);
+	}
 
 	tenured->here = tenured->start + h->data_size;
 	data_relocation_base = h->data_relocation_base;
@@ -44,9 +50,16 @@ INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
 
 	init_code_heap(p->code_size);
 
-	if(h->code_size != 0
+	if(h->code_size != 0)
-		&& fread(first_block(&code_heap),h->code_size,1,file) != 1)
+	{
+		long int bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
+		if(bytes_read != h->code_size)
+		{
+			fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n",
+				bytes_read,h->code_size);
 			fatal_error("load_code_heap failed",0);
+		}
+	}
 
 	code_relocation_base = h->code_relocation_base;
 	build_free_list(&code_heap,h->code_size);