diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index 987122f05c..7a12a3cc97 100644 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -1,61 +1,59 @@ -USING: kernel parser namespaces quotations arrays vectors strings - sequences assocs classes.tuple math combinators ; +USING: kernel parser combinators sequences splitting quotations arrays macros + arrays.lib combinators.cleave combinators.conditional newfx ; IN: bake ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: insert-quot expr ; +SYMBOL: , +SYMBOL: @ -C: insert-quot - -: ,[ \ ] [ >quotation ] parse-literal ; parsing +: comma? ( obj -- ? ) , = ; +: atsym? ( obj -- ? ) @ = ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: splice-quot expr ; +DEFER: [bake-array] -C: splice-quot - -: %[ \ ] [ >quotation ] parse-literal ; parsing +: broil-element ( obj -- quot ) + { + { [ 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 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 - -: 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 ; + append ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: `{ \ } [ >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 \ No newline at end of file diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index 701a784ea4..71aa2e8adc 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/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 diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index 8f4c0e30f5..28ce3e8b35 100644 --- a/extra/builder/release/release.factor +++ b/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 diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index db3b476365..320f0e0448 100644 --- a/extra/builder/util/util.factor +++ b/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 diff --git a/extra/combinators/conditional/conditional.factor b/extra/combinators/conditional/conditional.factor new file mode 100644 index 0000000000..cb27ef3f55 --- /dev/null +++ b/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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index 37c738cd6a..0e24ff2507 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -195,4 +195,27 @@ METHOD: as-mutate { object object assoc } set-at ; : adjoin ( seq elt -- seq ) over sets:adjoin ; : adjoin-on ( elt seq -- seq ) tuck sets:adjoin ; : adjoined ( set elt -- ) swap sets:adjoin ; -: adjoined-on ( elt set -- ) sets:adjoin ; \ No newline at end of file +: 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 ; + diff --git a/extra/random-weighted/random-weighted.factor b/extra/random-weighted/random-weighted.factor index 59cc15cba6..3f7a5d09b5 100644 --- a/extra/random-weighted/random-weighted.factor +++ b/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 >alist ] bi swap - [ , random-weighted , case ] bake ; + [ keys ] [ values >alist ] bi + '[ , random-weighted , case ] ; diff --git a/extra/raptor/raptor.factor b/extra/raptor/raptor.factor index d58e242d86..933275e5bf 100755 --- a/extra/raptor/raptor.factor +++ b/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 diff --git a/extra/rewrite-closures/rewrite-closures.factor b/extra/rewrite-closures/rewrite-closures.factor index ccd3989d1a..198e1744bc 100644 --- a/extra/rewrite-closures/rewrite-closures.factor +++ b/extra/rewrite-closures/rewrite-closures.factor @@ -1,30 +1,26 @@ -USING: kernel parser math quotations namespaces sequences namespaces.lib - inference.transforms ; +USING: kernel parser math quotations namespaces sequences macros fry ; 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 ; - -: 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* ; +MACRO: set-parameters ( seq -- quot ) [set-parameters] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/size-of/size-of.factor b/extra/size-of/size-of.factor index a2b47fc0aa..8157ba7dcf 100644 --- a/extra/size-of/size-of.factor +++ b/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 " include-headers { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" } } - bake to-strings ; + to-strings ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/springies/models/2x2snake/2x2snake.factor b/extra/springies/models/2x2snake/2x2snake.factor index 7c54e72578..6e794eb744 100644 --- a/extra/springies/models/2x2snake/2x2snake.factor +++ b/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 diff --git a/extra/springies/models/3snake/3snake.factor b/extra/springies/models/3snake/3snake.factor index 92d39ac2c2..e65c9c64a6 100644 --- a/extra/springies/models/3snake/3snake.factor +++ b/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 -- ) - [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ; +! : go* ( quot -- ) +! [ [ [ 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 ; diff --git a/extra/springies/models/belt-tire/belt-tire.factor b/extra/springies/models/belt-tire/belt-tire.factor index 6604f85a3f..e00a93b310 100644 --- a/extra/springies/models/belt-tire/belt-tire.factor +++ b/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 diff --git a/extra/springies/models/nifty/nifty.factor b/extra/springies/models/nifty/nifty.factor index db644f2248..2b9a31b234 100644 --- a/extra/springies/models/nifty/nifty.factor +++ b/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 diff --git a/extra/springies/models/urchin/urchin.factor b/extra/springies/models/urchin/urchin.factor index 734a1c2f6d..8870c714e8 100644 --- a/extra/springies/models/urchin/urchin.factor +++ b/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 diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index bebe813925..8aabe6b70b 100644 --- a/extra/springies/ui/ui.factor +++ b/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 -- ) - [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ; +: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ; \ No newline at end of file diff --git a/vm/image.c b/vm/image.c index 141594f01f..09ff035d7e 100755 --- a/vm/image.c +++ b/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 - && fread(first_block(&code_heap),h->code_size,1,file) != 1) - fatal_error("load_code_heap failed",0); + if(h->code_size != 0) + { + 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);