Merge git://factorcode.org/git/factor

Factor.app/Contents/Info.plist

@@ -22,7 +22,7 @@
 	<key>CFBundleExecutable</key>
 	<string>factor</string>
 	<key>CFBundleIconFile</key>
-	<string>FRaptorMix.icns</string>
+	<string>Factor.icns</string>
 	<key>CFBundleIdentifier</key>
 	<string>org.factorcode.Factor</string>
 	<key>CFBundleInfoDictionaryVersion</key>

core/bootstrap/image/image.factor

@@ -36,7 +36,7 @@ IN: bootstrap.image
 : wrapper@ bootstrap-cell object tag-number - ;
 : word-xt@ 8 bootstrap-cells object tag-number - ;
 : quot-array@ bootstrap-cell object tag-number - ;
-: quot-xt@ 2 bootstrap-cells object tag-number - ;
+: quot-xt@ 3 bootstrap-cells object tag-number - ;
 
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
@@ -312,6 +312,7 @@ M: quotation '
         quotation-array '
         quotation type-number object tag-number [
             emit ! array
+            f ' emit ! compiled?
             0 emit ! XT
         ] emit-object
     ] cache ;

core/bootstrap/primitives.factor

@@ -452,6 +452,13 @@ num-types get f <array> builtins set
         { "quotation-array" "quotations.private" }
         f
     }
+    {
+        { "object" "kernel" }
+        "compiled?"
+        2
+        { "quotation-compiled?" "quotations" }
+        f
+    }
 } define-builtin
 
 "dll" "alien" create "dll?" "alien" create

core/optimizer/debugger/debugger.factor

@@ -3,7 +3,7 @@
 USING: classes inference inference.dataflow io kernel
 kernel.private math.parser namespaces optimizer prettyprint
 prettyprint.backend sequences words arrays match macros
-assocs ;
+assocs combinators.private ;
 IN: optimizer.debugger
 
 ! A simple tool for turning dataflow IR into quotations, for

core/sequences/sequences.factor

@@ -191,14 +191,14 @@ TUPLE: slice from to seq ;
 TUPLE: slice-error reason ;
 : slice-error ( str -- * ) \ slice-error construct-boa throw ;
 
-: check-slice ( from to seq -- )
+: check-slice ( from to seq -- from to seq )
     pick 0 < [ "start < 0" slice-error ] when
-    length over < [ "end > sequence" slice-error ] when
-    > [ "start > end" slice-error ] when ;
+    dup length pick < [ "end > sequence" slice-error ] when
+    pick pick > [ "start > end" slice-error ] when ;
 
 : <slice> ( from to seq -- slice )
     dup slice? [ collapse-slice ] when
-    3dup check-slice
+    check-slice
     slice construct-boa ;
 
 M: slice virtual-seq slice-seq ;
@@ -259,7 +259,7 @@ INSTANCE: repetition immutable-sequence
 PRIVATE>
 
 : subseq ( from to seq -- subseq )
-    [ 3dup check-slice prepare-subseq (copy) ] keep like ;
+    [ check-slice prepare-subseq (copy) ] keep like ;
 
 : head ( seq n -- headseq ) (head) subseq ;
 
@@ -525,7 +525,7 @@ M: sequence <=>
     ] if ;
 
 : delete-slice ( from to seq -- )
-    3dup check-slice >r over >r - r> r> open-slice ;
+    check-slice >r over >r - r> r> open-slice ;
 
 : delete-nth ( n seq -- )
     >r dup 1+ r> delete-slice ;

extra/benchmark/dispatch4/dispatch4.factor

@@ -1,4 +1,5 @@
-USING: kernel.private kernel sequences math combinators ;
+USING: kernel.private kernel sequences math combinators
+combinators.private ;
 IN: benchmark.dispatch4
 
 : foobar-1

extra/boids/boids.factor

@@ -56,7 +56,7 @@ VAR: separation-radius
 ! random-boid and random-boids
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: random-range ( a b -- n ) 1 + dupd swap - random + ;
+: random-range ( a b -- n ) 1+ over - random + ;
 
 : random-pos ( -- pos ) world-size> [ random ] map ;
 
@@ -68,7 +68,7 @@ VAR: separation-radius
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: distance ( boid boid -- n ) boid-pos swap boid-pos v- norm ;
+: distance ( boid boid -- n ) [ boid-pos ] [ boid-pos ] bi* v- norm ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -79,7 +79,7 @@ VAR: separation-radius
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: relative-position ( self other -- v ) boid-pos swap boid-pos v- ;
+: relative-position ( self other -- v ) swap [ boid-pos ] 2apply v- ;
 
 : relative-angle ( self other -- angle )
 over boid-vel -rot relative-position angle-between ;
@@ -88,7 +88,7 @@ over boid-vel -rot relative-position angle-between ;
 
 : vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
 
-: vaverage ( seq-of-vectors -- seq ) dup vsum swap length v/n ;
+: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
 
 : average-position ( boids -- pos ) [ boid-pos ] map vaverage ;
 
@@ -204,14 +204,14 @@ cond ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: new-pos ( boid -- pos ) dup boid-vel time-slice> v*n swap boid-pos v+ ;
+: new-pos ( boid -- pos ) [ boid-pos ] [ boid-vel time-slice> v*n ] bi v+ ;
 
 : new-vel ( boid -- vel )
-dup acceleration time-slice> v*n swap boid-vel v+ normalize* ;
+  [ boid-vel ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
 
 : wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ;
 
-: iterate-boid ( self -- self ) dup >r new-pos wrap-pos r> new-vel <boid> ;
+: iterate-boid ( self -- self ) [ new-pos wrap-pos ] [ new-vel ] bi <boid> ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/boids/ui/ui.factor

@@ -18,7 +18,7 @@ USING: kernel namespaces
        ui.gadgets.packs
        ui.gadgets.grids
        ui.gestures
-       hashtables.lib vars rewrite-closures boids ;
+       combinators.lib hashtables.lib vars rewrite-closures boids ;
 
 IN: boids.ui
 
@@ -26,16 +26,13 @@ IN: boids.ui
 ! draw-boid
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: boid-point-a ( boid -- a ) boid-pos ;
+: point-a ( boid -- a ) boid-pos ;
 
-: boid-point-b ( boid -- b ) dup boid-pos swap boid-vel normalize* 20 v*n v+ ;
+: point-b ( boid -- b ) [ boid-pos ] [ boid-vel normalize* 20 v*n ] bi v+ ;
 
-: boid-points ( boid -- point-a point-b ) dup boid-point-a swap boid-point-b ;
+: boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ;
 
-: draw-line ( a b -- )
-GL_LINES glBegin first2 glVertex2d first2 glVertex2d glEnd ;
-
-: draw-boid ( boid -- ) boid-points draw-line ;
+: draw-boid ( boid -- ) boid-points gl-line ;
 
 : draw-boids ( -- ) boids> [ draw-boid ] each ;
 

extra/cairo-demo/cairo-demo.factor

@@ -0,0 +1,72 @@
+! Cairo "Hello World" demo
+!  Copyright (c) 2007 Sampo Vuori
+!    License: http://factorcode.org/license.txt
+!
+! This example is an adaptation of the following cairo sample code:
+!  http://cairographics.org/samples/text/
+
+
+USING: cairo math math.constants byte-arrays kernel ui ui.render
+	   ui.gadgets opengl.gl ;
+
+IN: cairo-demo
+
+
+: make-image-array ( -- array )
+  384 256 4 * * <byte-array> ;
+
+: convert-array-to-surface ( array -- cairo_surface_t )
+  CAIRO_FORMAT_ARGB32 384 256 over 4 *
+  cairo_image_surface_create_for_data ;
+
+
+TUPLE: cairo-gadget image-array cairo-t ;
+
+M: cairo-gadget draw-gadget* ( gadget -- )
+   0 0 glRasterPos2i
+   1.0 -1.0 glPixelZoom
+   >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
+   cairo-gadget-image-array glDrawPixels ;
+
+: create-surface ( gadget -- cairo_surface_t )
+  make-image-array dup >r swap set-cairo-gadget-image-array r> convert-array-to-surface ;
+
+: init-cairo ( gadget -- cairo_t )
+   create-surface cairo_create ;
+
+M: cairo-gadget pref-dim* drop { 384 256 0 } ;
+
+: draw-hello-world ( gadget -- )
+  cairo-gadget-cairo-t
+  dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face
+  dup 90.0 cairo_set_font_size
+  dup 10.0 135.0 cairo_move_to
+  dup "Hello" cairo_show_text
+  dup 70.0 165.0 cairo_move_to
+  dup "World" cairo_text_path
+  dup 0.5 0.5 1 cairo_set_source_rgb
+  dup cairo_fill_preserve
+  dup 0 0 0 cairo_set_source_rgb
+  dup 2.56 cairo_set_line_width
+  dup cairo_stroke
+  dup 1 0.2 0.2 0.6 cairo_set_source_rgba
+  dup 10.0 135.0 5.12 0 pi 2 * cairo_arc
+  dup cairo_close_path
+  dup 70.0 165.0 5.12 0 pi 2 * cairo_arc
+  cairo_fill ;
+
+M: cairo-gadget graft* ( gadget -- )
+   dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
+
+M: cairo-gadget ungraft* ( gadget -- )
+   cairo-gadget-cairo-t cairo_destroy ;
+
+: <cairo-gadget> ( -- gadget )
+  cairo-gadget construct-gadget ;
+
+: run ( -- )
+  [
+	<cairo-gadget> "Hello World from Factor!" open-window
+  ] with-ui ;
+
+MAIN: run

extra/cairo/cairo.factor

@@ -1,6 +1,25 @@
-! Cairo binding
+! Bindings for Cairo library
+!  Copyright (c) 2007 Sampo Vuori
+!    License: http://factorcode.org/license.txt
+
+! Unimplemented:
+!  - most of the font stuff
+!  - most of the matrix stuff
+!  - most of the query functions
+
+
+USING: alien alien.syntax combinators system ;
+
 IN: cairo
-USING: alien alien.syntax ;
+
+: load-cairo-library ( -- )
+  "cairo" {
+	{ [ win32? ] [ "cairo.dll" ] }
+	{ [ macosx? ] [ "libcairo.dylib" ] }
+	{ [ unix? ] [ "libcairo.so.2" ] }
+  } cond "cdecl" add-library ; parsing
+
+load-cairo-library
 
 ! cairo_status_t
 C-ENUM:
@@ -10,24 +29,43 @@ C-ENUM:
     CAIRO_STATUS_INVALID_POP_GROUP
     CAIRO_STATUS_NO_CURRENT_POINT
     CAIRO_STATUS_INVALID_MATRIX
-    CAIRO_STATUS_NO_TARGET_SURFACE
+    CAIRO_STATUS_INVALID_STATUS
     CAIRO_STATUS_NULL_POINTER
     CAIRO_STATUS_INVALID_STRING
+    CAIRO_STATUS_INVALID_PATH_DATA
+    CAIRO_STATUS_READ_ERROR
+    CAIRO_STATUS_WRITE_ERROR
+    CAIRO_STATUS_SURFACE_FINISHED
+    CAIRO_STATUS_SURFACE_TYPE_MISMATCH
+    CAIRO_STATUS_PATTERN_TYPE_MISMATCH
+    CAIRO_STATUS_INVALID_CONTENT
+    CAIRO_STATUS_INVALID_FORMAT
+    CAIRO_STATUS_INVALID_VISUAL
+    CAIRO_STATUS_FILE_NOT_FOUND
+    CAIRO_STATUS_INVALID_DASH
+    CAIRO_STATUS_INVALID_DSC_COMMENT
+    CAIRO_STATUS_INVALID_INDEX
+    CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
 ;
 
+! cairo_content_t
+: CAIRO_CONTENT_COLOR HEX: 1000 ;
+: CAIRO_CONTENT_ALPHA HEX: 2000 ;
+: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
+
 ! cairo_operator_t
 C-ENUM:
     CAIRO_OPERATOR_CLEAR
-    CAIRO_OPERATOR_SRC
-    CAIRO_OPERATOR_DST
+    CAIRO_OPERATOR_SOURCE
     CAIRO_OPERATOR_OVER
-    CAIRO_OPERATOR_OVER_REVERSE
     CAIRO_OPERATOR_IN
-    CAIRO_OPERATOR_IN_REVERSE
     CAIRO_OPERATOR_OUT
-    CAIRO_OPERATOR_OUT_REVERSE
     CAIRO_OPERATOR_ATOP
-    CAIRO_OPERATOR_ATOP_REVERSE
+    CAIRO_OPERATOR_DEST
+    CAIRO_OPERATOR_DEST_OVER
+    CAIRO_OPERATOR_DEST_IN
+    CAIRO_OPERATOR_DEST_OUT
+    CAIRO_OPERATOR_DEST_ATOP
     CAIRO_OPERATOR_XOR
     CAIRO_OPERATOR_ADD
     CAIRO_OPERATOR_SATURATE
@@ -116,6 +154,14 @@ C-STRUCT: cairo_t
     { "cairo_gstate_t*" "gstate" }
     { "uint" "status ! cairo_status_t" } ;
 
+C-STRUCT: cairo_matrix_t
+	{ "double" "xx" }
+	{ "double" "yx" }
+	{ "double" "xy" }
+	{ "double" "yy" }
+	{ "double" "x0" }
+	{ "double" "y0" } ;
+
 ! cairo_format_t
 C-ENUM:
     CAIRO_FORMAT_ARGB32
@@ -160,15 +206,24 @@ C-ENUM:
 : cairo_create ( cairo_surface_t -- cairo_t )
     "cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ;
 
+: cairo_reference ( cairo_t -- cairo_t )
+  	"cairo_t*" "cairo" "cairo_reference" [ "cairo_t*" ] alien-invoke ;
+
 : cairo_destroy ( cairo_t -- )
     "void" "cairo" "cairo_destroy" [ "cairo_t*" ] alien-invoke ;
 
+: cairo_save ( cairo_t -- )
+  	"void" "cairo" "cairo_save" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_restore ( cairo_t -- )
+  	"void" "cairo" "cairo_restore" [ "cairo_t*" ] alien-invoke ;
+
 : cairo_set_operator ( cairo_t cairo_operator_t -- )
     "void" "cairo" "cairo_set_operator" [ "cairo_t*" "int" ] alien-invoke ;
 
-: cairo_image_surface_create_for_data ( data format width height stride -- cairo_surface_t )
-    "void*" "cairo" "cairo_image_surface_create_for_data" [ "void*" "uint" "int" "int" "int" ] alien-invoke ;
-    
+: cairo_set_source ( cairo_t cairo_pattern_t -- )
+    "void" "cairo" "cairo_set_source" [ "cairo_t*" "void*" ] alien-invoke ;
+
 : cairo_set_source_rgb ( cairo_t red green blue -- )
     "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" ] alien-invoke ;
 
@@ -181,6 +236,10 @@ C-ENUM:
 : cairo_set_tolerance ( cairo_t tolerance -- )
     "void" "cairo" "cairo_set_tolerance" [ "cairo_t*" "double" ] alien-invoke ;
 
+: cairo_image_surface_create_for_data ( data format width height stride -- cairo_surface_t )
+    "void*" "cairo" "cairo_image_surface_create_for_data" [ "void*" "uint" "int" "int" "int" ] alien-invoke ;
+    
+
 : cairo_set_antialias ( cairo_t cairo_antialias_t -- )
     "void" "cairo" "cairo_set_antialias" [ "cairo_t*" "int" ] alien-invoke ;
 
@@ -211,6 +270,14 @@ C-ENUM:
 : cairo_rotate ( cairo_t angle -- )
     "void" "cairo" "cairo_rotate" [ "cairo_t*" "double" ] alien-invoke ;
 
+: cairo_transform ( cairo_t cairo_matrix_t -- )
+  	"void" "cairo" "cairo_transform" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
+
+: cairo_set_matrix ( cairo_t cairo_matrix_t -- )
+  	"void" "cairo" "cairo_set_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
+
+: cairo_identity_matrix ( cairo_t -- )
+  	"void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ;
 
 ! cairo path creating functions
 
@@ -219,6 +286,9 @@ C-ENUM:
 
 : cairo_move_to ( cairo_t x y -- )
     "void" "cairo" "cairo_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
+
+: cairo_new_sub_path ( cairo_t -- )
+    "void" "cairo" "cairo_new_sub_path" [ "cairo_t*" ] alien-invoke ;
     
 : cairo_line_to ( cairo_t x y -- )
     "void" "cairo" "cairo_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
@@ -247,6 +317,29 @@ C-ENUM:
 : cairo_close_path ( cairo_t -- )
     "void" "cairo" "cairo_close_path" [ "cairo_t*" ] alien-invoke ;
 
+! Surface manipulation
+
+: cairo_surface_create_similar ( cairo_surface_t cairo_content_t width height -- cairo_surface_t )
+    "cairo_surface_t*" "cairo" "cairo_surface_create_similar" [ "cairo_surface_t*" "uint" "int" "int" ] alien-invoke ;
+
+: cairo_surface_reference ( cairo_surface_t -- cairo_surface_t )
+    "cairo_surface_t*" "cairo" "cairo_surface_reference" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_finish ( cairo_surface_t -- )
+    "void" "cairo" "cairo_surface_finish" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_destroy ( cairo_surface_t -- )
+    "void" "cairo" "cairo_surface_destroy" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_get_reference_count ( cairo_surface_t -- count )
+    "uint" "cairo" "cairo_surface_get_reference_count" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_status ( cairo_surface_t -- cairo_status_t )
+    "uint" "cairo" "cairo_surface_status" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_flush ( cairo_surface_t -- )
+    "void" "cairo" "cairo_surface_flush" [ "cairo_surface_t*" ] alien-invoke ;
+
 ! painting functions
 : cairo_paint ( cairo_t -- )
     "void" "cairo" "cairo_paint" [ "cairo_t*" ] alien-invoke ;
@@ -302,8 +395,6 @@ C-ENUM:
 : cairo_clip_preserve ( cairo_t -- )
     "void" "cairo" "cairo_clip_preserve" [ "cairo_t*" ] alien-invoke ;
 
-: cairo_set_source ( cairo_t cairo_pattern_t -- )
-    "void" "cairo" "cairo_set_source" [ "cairo_t*" "void*" ] alien-invoke ;
 
 : cairo_pattern_create_linear ( x0 y0 x1 y1 -- cairo_pattern_t )
     "void*" "cairo" "cairo_pattern_create_linear" [ "double" "double" "double" "double" ] alien-invoke ;
@@ -326,5 +417,26 @@ C-ENUM:
 : cairo_set_font_size ( cairo_t scale -- )
     "void" "cairo" "cairo_set_font_size" [ "cairo_t*" "double" ] alien-invoke ;
 
-: cairo_identity_matrix ( cairo_t -- )
-    "void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ;
+: cairo_set_font_matrix ( cairo_t cairo_matrix_t -- )
+  	"void" "cairo" "cairo_set_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
+
+: cairo_get_font_matrix ( cairo_t cairo_matrix_t -- )
+  	"void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
+
+
+
+! Cairo pdf
+
+: cairo_pdf_surface_create ( filename width height -- surface )
+  "void*" "cairo" "cairo_pdf_surface_create" [ "char*" "double" "double" ] alien-invoke ;
+
+! Missing:
+
+! cairo_public cairo_surface_t *
+! cairo_pdf_surface_create_for_stream (cairo_write_func_t write_func,
+!                                      void              *closure,
+!                                      double             width_in_points,
+!                                      double             height_in_points);
+
+: cairo_pdf_surface_set_size ( surface width height -- )
+  "void" "cairo" "cairo_pdf_surface_set_size" [ "void*" "double" "double" ] alien-invoke ;

extra/cfdg/hsv/hsv.factor

@@ -1,5 +1,5 @@
 
-USING: kernel combinators arrays sequences math ;
+USING: kernel combinators arrays sequences math combinators.lib ;
 
 IN: cfdg.hsv
 
@@ -15,13 +15,13 @@ IN: cfdg.hsv
 
 : Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
 
-: f ( hsv -- f ) dup H 60 / swap Hi - ;
+: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
 
-: p ( hsv -- p ) 1 over S - swap V * ;
+: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
 
-: q ( hsv -- q ) dup f over S * 1 swap - swap V * ;
+: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
 
-: t ( hsv -- t ) 1 over f - over S * 1 swap - swap V * ;
+: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
 
 PRIVATE>
 
@@ -31,9 +31,9 @@ PRIVATE>
 
 : hsv>rgb ( hsv -- rgb )
 dup Hi
-{ { 0 [ dup V swap dup t swap p ] }
-  { 1 [ dup q over V rot p ] }
-  { 2 [ dup p over V rot t ] }
-  { 3 [ dup p over q rot V ] }
-  { 4 [ dup t over p rot V ] }
-  { 5 [ dup V over p rot q ] } } case 3array ;
+{ { 0 [ [ V ] [ t ] [ p ] tri ] }
+  { 1 [ [ q ] [ V ] [ p ] tri ] }
+  { 2 [ [ p ] [ V ] [ t ] tri ] }
+  { 3 [ [ p ] [ q ] [ V ] tri ] }
+  { 4 [ [ t ] [ p ] [ V ] tri ] }
+  { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;

extra/cfdg/models/flower6/flower6.factor

@@ -19,6 +19,7 @@ iterate? [
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : run ( -- )
+[ ] >background
 { -1 2 -1 2 } viewport set
 0.01 threshold set
 [ flower6 ] start-shape set

extra/cfdg/models/lesson/lesson.factor

@@ -97,6 +97,7 @@ iterate? [
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : run ( -- )
+[ ] >background
 { -5 25 -15 25 } viewport set
 0.03 threshold set
 [ toc ] start-shape set

extra/cfdg/models/snowflake/snowflake.factor

@@ -26,6 +26,7 @@ spike
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : run ( -- )
+[ ] >background
 { -40 80 -40 80 } viewport set
 0.1 threshold set
 [ snowflake ] start-shape set

extra/channels/sniffer/bsd/bsd.factor

@@ -3,7 +3,7 @@
 !
 ! Wrap a sniffer in a channel
 USING: kernel channels channels.sniffer concurrency io
-io.sniffer io.sniffer.bsd ;
+io.sniffer io.sniffer.bsd io.unix.backend ;
 
 M: unix-io sniff-channel ( -- channel ) 
   "/dev/bpf0" "en1" <sniffer-spec> <sniffer> <channel> [

extra/concurrency/concurrency.factor

@@ -239,7 +239,7 @@ PRIVATE>
         "Exiting process: " write self process-pid print
     ] curry spawn-link ;
 
-: server-cc ( -- cc | process )
+: server-cc ( -- cc|process )
     #! Captures the current continuation and returns the value.
     #! If that CC is called with a process on the stack it will
     #! set 'self' for the current process to it. Otherwise it will

extra/cpu/8080/8080.factor

@@ -3,7 +3,8 @@
 !
 USING: kernel math sequences words arrays io 
        io.files namespaces math.parser kernel.private
-       assocs quotations parser parser-combinators tools.time ;
+       assocs quotations parser parser-combinators tools.time
+       combinators.private ;
 IN: cpu.8080
 
 TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;

extra/furnace/furnace.factor

@@ -118,18 +118,18 @@ SYMBOL: model
 
 : render-page* ( model body-template head-template -- )
     [
-        [ render-template ] [ f rot render-template ] html-document* 
+        [ render-template ] [ f rot render-template ] html-document 
     ] serve-html ;
 
 : render-titled-page* ( model body-template head-template title -- )
     [ 
-        [ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document* 
+        [ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document
     ] serve-html ;
 
 
 : render-page ( model template title -- )
     [
-        [ render-template ] html-document
+        [ render-template ] simple-html-document
     ] serve-html ;
 
 : web-app ( name default path -- )

extra/html/elements/elements.factor

@@ -152,5 +152,5 @@ SYMBOL: html
     "size" "href" "class" "border" "rows" "cols" 
     "id" "onclick" "style" "valign" "accesskey"
     "src" "language" "colspan" "onchange" "rel"
-    "width" "selected" "onsubmit"
+    "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
 ] [ define-attribute-word ] each 

extra/html/html-tests.factor

@@ -1,30 +1,39 @@
 USING: html http io io.streams.string io.styles kernel
-namespaces tools.test xml.writer ;
+namespaces tools.test xml.writer sbufs sequences html.private ;
 IN: temporary
 
-[
-    "/responder/foo?z=%20"
-] [
-    "/responder/foo" H{ { "z" " " } } build-url
+: make-html-string
+    [ with-html-stream ] string-out ;
+
+[ ] [
+    512 <sbuf> <html-stream> drop
 ] unit-test
 
-[
-    "&lt;html&gt;&amp;&apos;sgml&apos;"
-] [ "<html>&'sgml'" chars>entities ] unit-test
+[ "" ] [
+    [ "" write ] make-html-string
+] unit-test
 
-[ "" ]
-[
+[ "a" ] [
+    [ CHAR: a write1 ] make-html-string
+] unit-test
+
+[ "&lt;" ] [
+    [ "<" write ] make-html-string
+] unit-test
+
+[ "<" ] [
+    [ "<" H{ } stdio get format-html-span ] make-html-string
+] unit-test
+
+TUPLE: funky town ;
+
+M: funky browser-link-href
+    "http://www.funky-town.com/" swap funky-town append ;
+
+[ "<a href='http://www.funky-town.com/austin'>&lt;</a>" ] [
     [
-        H{ } [ drop ] span-tag
-    ] string-out
-] unit-test
-
-: html-format ( string style -- string )
-    [ format ] with-html-stream ;
-
-[ "hello world" ]
-[
-    [ "hello world" H{ } html-format ] string-out
+        "<" "austin" funky construct-boa write-object
+    ] make-html-string
 ] unit-test
 
 [ "<span style='font-family: monospace; '>car</span>" ]
@@ -32,8 +41,8 @@ IN: temporary
     [
         "car"
         H{ { font "monospace" } }
-        html-format
-    ] string-out
+        format
+    ] make-html-string
 ] unit-test
 
 [ "<span style='color: #ff00ff; '>car</span>" ]
@@ -41,6 +50,14 @@ IN: temporary
     [
         "car"
         H{ { foreground { 1 0 1 1 } } }
-        html-format
-    ] string-out
+        format
+    ] make-html-string
+] unit-test
+
+[ "<div style='background-color: #ff00ff; '>cdr</div>" ]
+[
+    [
+        H{ { page-color { 1 0 1 1 } } }
+        [ "cdr" write ] with-nesting
+    ] make-html-string
 ] unit-test

extra/html/html.factor

@@ -1,10 +1,43 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: generic assocs help http io io.styles io.files io.streams.string
-kernel math math.parser namespaces xml.writer quotations
-assocs sequences strings words html.elements ;
+USING: generic assocs help http io io.styles io.files
+io.streams.string kernel math math.parser namespaces
+quotations assocs sequences strings words html.elements
+xml.writer sbufs ;
 IN: html
 
+GENERIC: browser-link-href ( presented -- href )
+
+M: object browser-link-href drop f ;
+
+TUPLE: html-stream ;
+
+: <html-stream> ( stream -- stream )
+    html-stream construct-delegate ;
+
+<PRIVATE
+
+TUPLE: html-sub-stream style stream ;
+
+: (html-sub-stream) ( style stream -- stream )
+    html-sub-stream construct-boa
+    512 <sbuf> <html-stream> over set-delegate ;
+
+: <html-sub-stream> ( style stream class -- stream )
+    >r (html-sub-stream) r> construct-delegate ; inline
+
+: end-sub-stream ( substream -- string style stream )
+    dup delegate >string
+    over html-sub-stream-style
+    rot html-sub-stream-stream ;
+
+: delegate-write ( string -- )
+    stdio get delegate stream-write ;
+
+: object-link-tag ( style quot -- )
+    presented pick at browser-link-href
+    [ <a =href a> call </a> ] [ call ] if* ; inline
+
 : hex-color, ( triplet -- )
     3 head-slice
     [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
@@ -28,166 +61,149 @@ IN: html
 : font-css, ( font -- )
     "font-family: " % % "; " % ;
 
-: hash-apply ( value-hash quot-hash -- )
-    #! Looks up the key of each pair in the first list in the
-    #! second list to produce a quotation. The quotation is
-    #! applied to the value of the pair. If there is no
-    #! corresponding quotation, the value is popped off the
-    #! stack.
-    [ swapd at dup [ call ] [ 2drop ] if ] curry assoc-each ;
+: apply-style ( style key quot -- style gadget )
+    >r over at r> when* ; inline
+
+: make-css ( style quot -- str )
+    "" make nip ; inline
 
 : span-css-style ( style -- str )
     [
-        H{
-            { foreground  [ fg-css,        ] }
-            { background  [ bg-css,        ] }
-            { font        [ font-css,      ] }
-            { font-style  [ style-css,     ] }
-            { font-size   [ size-css,      ] }
-        } hash-apply
-    ] "" make ;
+        foreground [ fg-css,    ] apply-style
+        background [ bg-css,    ] apply-style
+        font       [ font-css,  ] apply-style
+        font-style [ style-css, ] apply-style
+        font-size  [ size-css,  ] apply-style
+    ] make-css ;
 
 : span-tag ( style quot -- )
     over span-css-style dup empty? [
         drop call
     ] [
         <span =style span> call </span>
-    ] if ;
+    ] if ; inline
+
+: format-html-span ( string style stream -- )
+    [
+        [ [ drop delegate-write ] span-tag ] object-link-tag
+    ] with-stream* ;
+
+TUPLE: html-span-stream ;
+
+M: html-span-stream stream-close
+    end-sub-stream format-html-span ;
 
 : border-css, ( border -- )
     "border: 1px solid #" % hex-color, "; " % ;
 
 : padding-css, ( padding -- ) "padding: " % # "px; " % ;
 
-: pre-css, ( -- )
-    "white-space: pre; font-family: monospace; " % ;
+: pre-css, ( margin -- )
+    [ "white-space: pre; font-family: monospace; " % ] unless ;
 
 : div-css-style ( style -- str )
     [
-        H{
-            { page-color [ bg-css, ] }
-            { border-color [ border-css, ] }
-            { border-width [ padding-css, ] }
-            { wrap-margin [ [ pre-css, ] unless ] }
-        } hash-apply
-    ] "" make ;
+        page-color   [ bg-css,      ] apply-style
+        border-color [ border-css,  ] apply-style
+        border-width [ padding-css, ] apply-style
+        wrap-margin  [ pre-css,     ] apply-style
+    ] make-css ;
 
 : div-tag ( style quot -- )
     swap div-css-style dup empty? [
         drop call
     ] [
         <div =style div> call </div>
-    ] if ;
+    ] if ; inline
 
-: do-escaping ( string style -- string )
-    html swap at [ chars>entities ] unless ;
-
-GENERIC: browser-link-href ( presented -- href )
-
-M: object browser-link-href drop f ;
-
-: object-link-tag ( style quot -- )
-    presented pick at browser-link-href
-    [ <a =href a> call </a> ] [ call ] if* ;
-
-TUPLE: nested-stream ;
-
-: <nested-stream> ( stream -- stream )
-    nested-stream construct-delegate ;
-
-M: nested-stream stream-close drop ;
-
-TUPLE: html-stream ;
-
-: <html-stream> ( stream -- stream )
-    html-stream construct-delegate ;
-
-M: html-stream stream-write1 ( char stream -- )
-    >r 1string r> stream-write ;
-
-: delegate-write delegate stream-write ;
-
-M: html-stream stream-write ( str stream -- )
-    >r chars>entities r> delegate-write ;
-
-: with-html-style ( quot style stream -- )
-    [ [ swap span-tag ] object-link-tag ] with-stream* ; inline
-
-M: html-stream with-stream-style ( quot style stream -- )
-    [ drop call ] -rot with-html-style ;
-
-M: html-stream stream-format ( str style stream -- )
-    [ do-escaping stdio get delegate-write ] -rot
-    with-html-style ;
-
-: with-html-stream ( quot -- )
-    stdio get <html-stream> swap with-stream* ;
-
-M: html-stream with-nested-stream ( quot style stream -- )
+: format-html-div ( string style stream -- )
     [
-        [
-            [
-                stdio get <nested-stream> swap with-stream*
-            ] div-tag
-        ] object-link-tag
+        [ [ delegate-write ] div-tag ] object-link-tag
     ] with-stream* ;
 
+TUPLE: html-block-stream ;
+
+M: html-block-stream stream-close ( quot style stream -- )
+    end-sub-stream format-html-div ;
+
 : border-spacing-css,
     "padding: " % first2 max 2 /i # "px; " % ;
 
 : table-style ( style -- str )
     [
-        H{
-            { table-border [ border-css,         ] }
-            { table-gap    [ border-spacing-css, ] }
-        } hash-apply
-    ] "" make ;
+        table-border [ border-css,         ] apply-style
+        table-gap    [ border-spacing-css, ] apply-style
+    ] make-css ;
 
 : table-attrs ( style -- )
     table-style " border-collapse: collapse;" append =style ;
 
+: do-escaping ( string style -- string )
+    html swap at [ chars>entities ] unless ;
+
+PRIVATE>
+
+! Stream protocol
+M: html-stream stream-write1 ( char stream -- )
+    >r 1string r> stream-write ;
+
+M: html-stream stream-write ( str stream -- )
+    >r chars>entities r> delegate stream-write ;
+
+M: html-stream make-span-stream ( style stream -- stream' )
+    html-span-stream <html-sub-stream> ;
+
+M: html-stream stream-format ( str style stream -- )
+    >r html over at [ >r chars>entities r> ] unless r>
+    format-html-span ;
+
+M: html-stream make-block-stream ( style stream -- stream' )
+    html-block-stream <html-sub-stream> ;
+
 M: html-stream stream-write-table ( grid style stream -- )
     [
         <table dup table-attrs table> swap [
             <tr> [
                 <td "top" =valign swap table-style =style td>
-                    write-html
+                    >string write-html
                 </td>
             ] curry* each </tr>
         ] curry* each </table>
     ] with-stream* ;
 
-M: html-stream make-table-cell ( quot style stream -- table-cell )
-    2drop [ with-html-stream ] string-out ;
+M: html-stream make-cell-stream ( style stream -- stream' )
+    (html-sub-stream) ;
 
-M: html-stream stream-nl [ <br/> ] with-stream* ;
+M: html-stream stream-nl ( stream -- )
+    [ <br/> ] with-stream* ;
 
-: default-css ( -- )
-    <link
-    "stylesheet" =rel "text/css" =type
-    "/responder/resources/stylesheet.css" =href
-    link/> ;
+! Utilities
+: with-html-stream ( quot -- )
+    stdio get <html-stream> swap with-stream* ;
 
 : xhtml-preamble
     "<?xml version=\"1.0\"?>" write-html
     "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
 
-: html-document* ( body-quot head-quot -- )
+: html-document ( body-quot head-quot -- )
     #! head-quot is called to produce output to go
     #! in the html head portion of the document.
     #! body-quot is called to produce output to go
     #! in the html body portion of the document.
     xhtml-preamble
-    <html " xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\"" write-html html>
+    <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
         <head> call </head>
         <body> call </body>
     </html> ;
-  
-: html-document ( title quot -- )
+
+: default-css ( -- )
+    <link
+    "stylesheet" =rel "text/css" =type
+    "/responder/resources/extra/html/stylesheet.css" =href
+    link/> ;
+
+: simple-html-document ( title quot -- )
     swap [
         <title> write </title>
         default-css
-    ] html-document* ;
-
-: simple-html-document ( title quot -- )
-    swap [ <pre> with-html-stream </pre> ] html-document ;
+    ] html-document ;

extra/http/http.factor

@@ -7,7 +7,7 @@ IN: http
 : header-line ( line -- )
     ": " split1 dup [ swap set ] [ 2drop ] if ;
 
-: (read-header) ( hash -- hash )
+: (read-header) ( -- )
     readln dup
     empty? [ drop ] [ header-line (read-header) ] if ;
 

extra/http/server/responders/continuation/examples/examples.factor

@@ -34,7 +34,7 @@ IN: http.server.responders.continuation.examples
     <h1> over write </h1>
     swap [ 
       <a =href a> "Next" write </a>
-    ] html-document 
+    ] simple-html-document 
   ] show 2drop ;
 
 : display-get-name-page ( -- name )
@@ -47,7 +47,7 @@ IN: http.server.responders.continuation.examples
         <input "text" =type "name" =name "20" =size input/>
         <input "submit" =type "Ok" =value input/>
       </form>
-    ] html-document
+    ] simple-html-document
   ] show "name" swap at ;
 
 : test-cont-responder ( -- )
@@ -71,7 +71,7 @@ IN: http.server.responders.continuation.examples
         <li> "Test responder1" [ test-cont-responder ] quot-href </li>
         <li> "Test responder2" [ test-cont-responder2 ] quot-href </li>
       </ol>
-    ] html-document 
+    ] simple-html-document 
   ] show-final ;
 
 : counter-example ( count -- )
@@ -87,7 +87,7 @@ IN: http.server.responders.continuation.examples
       "++" over 1quotation [ f ] swap append [ 1 + counter-example ] append quot-href
       "--" over 1quotation [ f ] swap append [ 1 - counter-example ] append quot-href
       drop
-    ] html-document 
+    ] simple-html-document 
   ] show drop ;
 
 : counter-example2 ( -- )
@@ -102,7 +102,7 @@ IN: http.server.responders.continuation.examples
       <h2> "counter" get unparse write </h2>
       "++" [ "counter" get 1 + "counter" set ] quot-href
       "--" [ "counter" get 1 - "counter" set ] quot-href
-    ] html-document 
+    ] simple-html-document 
   ] show 
   drop ;
 

extra/http/server/responders/file/file.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: calendar html io io.files kernel math math.parser http.server.responders
-http.server.templating namespaces parser sequences strings assocs hashtables
-debugger http.mime sorting ;
+USING: calendar html io io.files kernel math math.parser
+http.server.responders http.server.templating namespaces parser
+sequences strings assocs hashtables debugger http.mime sorting
+html.elements ;
 
 IN: http.server.responders.file
 
@@ -55,19 +56,25 @@ SYMBOL: page
     dup mime-type dup "application/x-factor-server-page" =
     [ drop serving-html run-page ] [ serve-static ] if ;
 
-: file. ( path name dirp -- )
-    "[DIR] " "      " ? write
-    dup <pathname> write-object nl ;
+: file. ( name dirp -- )
+    [ "/" append ] when
+    dup <a =href a> write </a> ;
 
-: directory. ( path -- )
-    directory sort-keys [ first2 file. ] each ;
+: directory. ( path request -- )
+    dup [
+        <h1> write </h1>
+        <ul>
+            directory sort-keys
+            [ <li> file. </li> ] assoc-each
+        </ul>
+    ] simple-html-document ;
 
 : list-directory ( directory -- )
     serving-html
      "method" get "head" = [
         drop
     ] [
-        "request" get [ directory. ] simple-html-document
+        "request" get directory.
     ] if ;
 
 : find-index ( filename -- path )
@@ -98,17 +105,17 @@ SYMBOL: page
     ] if ;
 
 global [
-    ! Javascript source used by ajax libraries
+    ! Serve up our own source code
     "resources" [ 
         [
-            "extra/http/server/resources/" resource-path "doc-root" set
+            "" resource-path "doc-root" set
             file-responder
         ] with-scope
     ] add-simple-responder
     
     ! Serves files from a directory stored in the "doc-root"
-    ! variable. You can set the variable in the global namespace,
-    ! or inside the responder.
+    ! variable. You can set the variable in the global
+    ! namespace, or inside the responder.
     "file" [ file-responder ] add-simple-responder
     
     ! The root directory is served by...

extra/http/server/responders/responders.factor

@@ -16,16 +16,16 @@ SYMBOL: responders
 : response ( header msg -- )
     "HTTP/1.0 " write print print-header ;
 
-: error-body ( error -- body )
+: error-body ( error -- )
     <html> <body> <h1> write </h1> </body> </html> ;
 
 : error-head ( error -- )
     dup log-error
-    H{ { "Content-Type" "text/html" } } over response ;
+    H{ { "Content-Type" "text/html" } } swap response ;
 
 : httpd-error ( error -- )
     #! This must be run from handle-request
-    error-head
+    dup error-head
     "head" "method" get = [ drop ] [ nl error-body ] if ;
 
 : bad-request ( -- )
@@ -101,7 +101,8 @@ SYMBOL: max-post-request
     dup "request" set ;
 
 : prepare-header ( -- )
-    read-header dup "header" set
+    read-header
+    dup "header" set
     dup log-headers
     read-post-request "response" set "raw-response" set ;
 

extra/icfp/2006/2006.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: kernel math sequences kernel.private namespaces arrays
-io io.files splitting io.binary math.functions vectors ;
+io io.files splitting io.binary math.functions vectors
+quotations combinators.private ;
 IN: universal-machine
 
 SYMBOL: regs

extra/io/sniffer/filter/bsd/bsd.factor

@@ -1,7 +1,7 @@
 USING: alien.c-types hexdump io io.backend io.sockets.headers
 io.sockets.headers.bsd kernel io.sniffer io.sniffer.bsd
 io.sniffer.filter io.streams.string io.unix.backend math
-sequences system ;
+sequences system byte-arrays ;
 IN: io.sniffer.filter.bsd
 
 ! http://www.iana.org/assignments/ethernet-numbers

extra/io/streams/null/null.factor

@@ -16,7 +16,10 @@ M: null-stream stream-write 2drop ;
 M: null-stream stream-nl drop ;
 M: null-stream stream-flush drop ;
 M: null-stream stream-format 3drop ;
-M: null-stream with-nested-stream rot drop with-stream* ;
+M: null-stream make-span-stream nip ;
+M: null-stream make-block-stream nip ;
+M: null-stream make-cell-stream nip ;
+M: null-stream stream-write-table 3drop ;
 
 : with-null-stream ( quot -- )
     T{ null-stream } swap with-stream* ; inline

extra/locals/locals.factor

@@ -4,7 +4,8 @@
 USING: kernel namespaces sequences sequences.private assocs
        math inference.transforms parser words quotations debugger
        macros arrays macros splitting combinators prettyprint.backend
-       definitions prettyprint hashtables combinators.lib ;
+       definitions prettyprint hashtables combinators.lib
+       prettyprint.sections ;
 
 IN: locals
 

extra/openal/macosx/macosx.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 IN: openal.macosx
-USING: openal alien.c-types kernel alien alien.syntax shuffle ;
+USING: openal alien.c-types kernel alien alien.syntax shuffle
+combinators.lib ;
 
 LIBRARY: alut
 

extra/space-invaders/space-invaders.factor

@@ -4,7 +4,8 @@
 USING: cpu.8080 openal math alien.c-types sequences kernel
        shuffle arrays io.files combinators kernel.private
        ui.gestures ui.gadgets ui.render opengl.gl system 
-       threads concurrency match ui byte-arrays combinators.lib ;
+       threads concurrency match ui byte-arrays combinators.lib
+       combinators.private ;
 IN: space-invaders
 
 TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;

extra/state-machine/state-machine.factor

@@ -1,5 +1,5 @@
-USING: kernel parser strings math namespaces sequences words io arrays 
-quotations debugger kernel.private ;
+USING: kernel parser strings math namespaces sequences words io
+arrays quotations debugger kernel.private combinators.private ;
 IN: state-machine
 
 : STATES:

extra/ui/gadgets/slate/slate.factor

@@ -8,7 +8,9 @@ TUPLE: slate action dim graft ungraft ;
 : <slate> ( action -- slate )
   slate construct-gadget
   tuck set-slate-action
-  { 100 100 } over set-slate-dim ;
+  { 100 100 } over set-slate-dim
+  [ ] over set-slate-graft
+  [ ] over set-slate-ungraft ;
 
 M: slate pref-dim* ( slate -- dim ) slate-dim ;
 

extra/webapps/help/help.factor

@@ -10,7 +10,7 @@ IN: webapps.help
     serving-html
     dup article-title [
         [ help ] with-html-stream
-    ] html-document ;
+    ] simple-html-document ;
 
 : string>topic ( string -- topic )
     " " split dup length 1 = [ first ] when ;
@@ -73,9 +73,10 @@ M: vocab-author browser-link-href
 "help" "show-help" "extra/webapps/help" web-app
 
 ! Hard-coding for factorcode.org
-M: pathname browser-link-href
-    pathname-string "resource:" ?head [
-        "http://factorcode.org/repos/Factor/" swap append
-    ] [
-        drop f
-    ] if ;
+PREDICATE: pathname resource-pathname
+    pathname-string "resource:" head? ;
+
+M: resource-pathname browser-link-href
+    pathname-string
+    "resource:" ?head drop
+    "/responder/resources/" swap append ;

extra/xml/utilities/utilities.factor

@@ -10,9 +10,9 @@ IN: xml.utilities
 TUPLE: process-missing process tag ;
 M: process-missing error.
     "Tag <" write
-    process-missing-tag print-name
+    dup process-missing-tag print-name
     "> not implemented on process process " write
-    dup process-missing-process word-name print ;
+    process-missing-process word-name print ;
 
 : run-process ( tag word -- )
     2dup "xtable" word-prop

misc/icons/license.txt

@@ -1,4 +1,4 @@
 The icons/images/jackets contained in this archive are
-Copyright (C) 2007 Elie CHAFTARI. All Rights Reserved.
+Copyright (C) 2007 Elie Chaftari. All Rights Reserved.
 
 See http://factorcode.org/license.txt for BSD license.

vm/cpu-ppc.S

@@ -4,7 +4,7 @@ in the public domain. */
 
 /* Note that the XT is passed to the quotation in r11 */
 #define CALL_OR_JUMP_QUOT \
-        lwz r11,5(r3)      /* load quotation-xt slot */ XX \
+        lwz r11,9(r3)      /* load quotation-xt slot */ XX \
 
 #define CALL_QUOT \
         CALL_OR_JUMP_QUOT XX \
@@ -40,11 +40,19 @@ in the public domain. */
 
 #define RESTORE(register,offset) lwz register,SAVE_AT(offset)(r1)
 
-DEF(void,c_to_factor,(CELL quot)):
-        mflr r0            /* get caller's return address */
-        stwu r1,-FRAME(r1) /* create a stack frame to hold non-volatile registers */
+#define PROLOGUE \
+	mflr r0 XX         /* get caller's return address */ \
+        stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
         SAVE_LR(r0)
 
+#define EPILOGUE \
+	LOAD_LR(r0) XX \
+        lwz r1,0(r1) XX    /* destroy the stack frame */ \
+        mtlr r0            /* get ready to return */
+
+DEF(void,c_to_factor,(CELL quot)):
+        PROLOGUE
+
 	SAVE(r13,0)        /* save GPRs */
                            /* don't save ds pointer */
                            /* don't save rs pointer */
@@ -92,9 +100,7 @@ DEF(void,c_to_factor,(CELL quot)):
                            /* don't restore ds pointer */
         RESTORE(r13,0)
 
-        LOAD_LR(r0)
-        lwz r1,0(r1)       /* destroy the stack frame */
-        mtlr r0            /* get ready to return */
+        EPILOGUE
         blr
 
 /* The JIT compiles an 'mr r4,r1' in front of every primitive call, since a
@@ -164,6 +170,13 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
 	mtlr r0
 	JUMP_QUOT          /* call the quotation */
 
+DEF(void,lazy_jit_compile,(CELL quot)):
+	mr r4,r1           /* save stack pointer */
+	PROLOGUE
+	bl MANGLE(jit_compile)
+	EPILOGUE
+        JUMP_QUOT          /* call the quotation */
+
 /* Thanks to Joshua Grams for this code.
 
 On PowerPC processors, we must flush the instruction cache manually

vm/cpu-ppc.h

@@ -11,6 +11,7 @@ void docol(CELL word);
 void undefined(CELL word);
 void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
 void throw_impl(CELL quot, F_STACK_FRAME *rewind);
+void lazy_jit_compile(CELL quot);
 void flush_icache(CELL start, CELL len);
 
 #define FRAME_SUCCESSOR(frame) (frame)->previous

vm/cpu-x86.32.S

@@ -9,6 +9,7 @@ and the callstack top is passed in EDX */
 #define XT_REG %ecx
 #define STACK_REG %esp
 #define DS_REG %esi
+#define RETURN_REG %eax
 
 #define CELL_SIZE 4
 
@@ -20,7 +21,7 @@ and the callstack top is passed in EDX */
 	pop %ebp ; \
 	pop %ebx
 
-#define QUOT_XT_OFFSET 5
+#define QUOT_XT_OFFSET 9
 #define PROFILING_OFFSET 25
 #define WORD_DEF_OFFSET 13
 #define WORD_XT_OFFSET 29

vm/cpu-x86.64.S

@@ -5,6 +5,7 @@
 #define XT_REG %rcx
 #define STACK_REG %rsp
 #define DS_REG %r14
+#define RETURN_REG %rax
 
 #define CELL_SIZE 8
 
@@ -20,7 +21,7 @@
 	pop %rbp ; \
 	pop %rbx
 
-#define QUOT_XT_OFFSET 13
+#define QUOT_XT_OFFSET 21
 #define PROFILING_OFFSET 53
 #define WORD_DEF_OFFSET 29
 #define WORD_XT_OFFSET 61

vm/cpu-x86.S

@@ -51,3 +51,15 @@ DEF(FASTCALL void,primitive_execute,(void)):
 DEF(FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
 	mov ARG1,STACK_REG                    /* rewind_to */
 	JUMP_QUOT
+
+DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
+	mov STACK_REG,ARG1           /* Save stack pointer */
+	push XT_REG                  /* Alignment */
+	push XT_REG
+	push XT_REG
+	call MANGLE(jit_compile)
+	mov RETURN_REG,ARG0          /* No-op on 32-bit */
+	pop XT_REG                   /* OK to clobber XT_REG here */
+	pop XT_REG
+	pop XT_REG
+        JUMP_QUOT                    /* Call the quotation */

vm/cpu-x86.h

@@ -28,5 +28,6 @@ FASTCALL void undefined(CELL word);
 FASTCALL void dosym(CELL word);
 FASTCALL void docol_profiling(CELL word);
 FASTCALL void docol(CELL word);
+FASTCALL void lazy_jit_compile(CELL quot);
 
 void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);

vm/data_gc.c

@@ -553,7 +553,7 @@ CELL collect_next(CELL scan)
 		break;
 	case QUOTATION_TYPE:
 		quot = (F_QUOTATION *)scan;
-		if(collecting_code && quot->xt != NULL)
+		if(collecting_code && quot->xt != lazy_jit_compile)
 			recursive_mark(quot->xt);
 		break;
 	case CALLSTACK_TYPE:

vm/debug.c

@@ -3,7 +3,12 @@
 void print_word(F_WORD* word, CELL nesting)
 {
 	if(type_of(word->name) == STRING_TYPE)
-		printf("%s",to_char_string(untag_string(word->name),true));
+	{
+		F_STRING *string = untag_string(word->name);
+		CELL i;
+		for(i = 0; i < string_capacity(string); i++)
+			putchar(cget(SREF(string,i)));
+	}
 	else
 	{
 		printf("#<not a string: ");
@@ -14,7 +19,11 @@ void print_word(F_WORD* word, CELL nesting)
 
 void print_string(F_STRING* str)
 {
-	printf("\"%s\"",to_char_string(str,true));
+	putchar('"');
+	CELL i;
+	for(i = 0; i < string_capacity(str); i++)
+		putchar(cget(SREF(str,i)));
+	putchar('"');
 }
 
 void print_array(F_ARRAY* array, CELL nesting)

vm/factor.c

@@ -126,14 +126,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 	userenv[EXECUTABLE_ENV] = tag_object(from_native_string(executable_path));
 	userenv[EMBEDDED_ENV] = (embedded ? T : F);
 
-	if(!untag_quotation(userenv[BOOT_ENV])->xt)
-	{
-		/* This can only happen when we're starting a stage2 bootstrap.
-		The stage1 bootstrapper doesn't attempt to compile quotations,
-		so we do it here. */
-		jit_compile_all();
-	}
-
 	nest_stacks();
 	c_to_factor_toplevel(userenv[BOOT_ENV]);
 	unnest_stacks();

vm/factor.rs

@@ -1,2 +1,2 @@
-fraptor ICON "misc/icons/FRaptorMix.ico"
+fraptor ICON "misc/icons/Factor.ico"
 

vm/image.c

@@ -154,17 +154,17 @@ void fixup_word(F_WORD *word)
 {
 	/* If this is a compiled word, relocate the code pointer. Otherwise,
 	reset it based on the primitive number of the word. */
-	if(word->compiledp != F)
-		code_fixup(&word->xt);
+	if(word->compiledp == F)
+		word->xt = default_word_xt(word);
 	else
-		update_xt(word);
+		code_fixup(&word->xt);
 }
 
 void fixup_quotation(F_QUOTATION *quot)
 {
-	/* quot->xt is only ever NULL at the start of stage2 bootstrap,
-	in this case the JIT compiles all quotations */
-	if(quot->xt)
+	if(quot->compiled == F)
+		quot->xt = lazy_jit_compile;
+	else
 		code_fixup(&quot->xt);
 }
 

vm/jit.c

@@ -34,8 +34,13 @@ bool jit_stack_frame_p(F_ARRAY *array)
 	return false;
 }
 
-void jit_compile(F_QUOTATION *quot)
+FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack)
 {
+	stack_chain->callstack_top = stack;
+
+	REGISTER_ROOT(tagged);
+
+	F_QUOTATION *quot = untag_quotation(tagged);
 	F_ARRAY *array = untag_object(quot->array);
 
 	REGISTER_UNTAGGED(quot);
@@ -150,21 +155,10 @@ void jit_compile(F_QUOTATION *quot)
 
 	UNREGISTER_UNTAGGED(quot);
 	quot->xt = xt;
-}
+	quot->compiled = T;
 
-void jit_compile_all(void)
-{
-	begin_scan();
-
-	CELL obj;
-	while((obj = next_object()) != F)
-	{
-		if(type_of(obj) == QUOTATION_TYPE)
-			jit_compile(untag_quotation(obj));
-	}
-
-	/* End the scan */
-	gc_off = false;
+	UNREGISTER_ROOT(tagged);
+	return tagged;
 }
 
 XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset)

vm/jit.h

@@ -1,3 +1,2 @@
-void jit_compile(F_QUOTATION *quot);
-void jit_compile_all(void);
+DLLEXPORT FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack);
 XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset);

vm/layouts.h

@@ -194,6 +194,8 @@ typedef struct {
 	CELL header;
 	/* tagged */
 	CELL array;
+	/* tagged */
+	CELL compiled;
 	/* untagged */
 	XT xt;
 } F_QUOTATION;

vm/run.c

@@ -20,23 +20,21 @@ void uncurry(CELL obj)
 	}
 }
 
-void update_xt(F_WORD* word)
+XT default_word_xt(F_WORD *word)
 {
-	word->compiledp = F;
-
 	if(word->def == T)
-		word->xt = dosym;
+		return dosym;
 	else if(type_of(word->def) == QUOTATION_TYPE)
 	{
 		if(profiling)
-			word->xt = docol_profiling;
+			return docol_profiling;
 		else
-			word->xt = docol;
+			return docol;
 	}
 	else if(type_of(word->def) == FIXNUM_TYPE)
-		word->xt = primitives[to_fixnum(word->def)];
+		return primitives[to_fixnum(word->def)];
 	else
-		word->xt = undefined;
+		return undefined;
 }
 
 DEFINE_PRIMITIVE(uncurry)

vm/run.h

@@ -145,7 +145,7 @@ INLINE CELL type_of(CELL tagged)
 DEFPUSHPOP(d,ds)
 DEFPUSHPOP(r,rs)
 
-void update_xt(F_WORD* word);
+XT default_word_xt(F_WORD *word);
 
 DECLARE_PRIMITIVE(execute);
 DECLARE_PRIMITIVE(call);

vm/stack.c

@@ -407,13 +407,12 @@ void stack_frame_to_array(F_STACK_FRAME *frame)
 		offset = F;
 
 #ifdef CALLSTACK_UP_P
-	#define I(n) (n)
+	set_array_nth(array,frame_index++,frame_executing(frame));
+	set_array_nth(array,frame_index++,offset);
 #else
-	#define I(n) (array_capacity(array) - (n) - 1)
+	set_array_nth(array,frame_index--,offset);
+	set_array_nth(array,frame_index--,frame_executing(frame));
 #endif
-
-	set_array_nth(array,I(frame_index++),frame_executing(frame));
-	set_array_nth(array,I(frame_index++),offset);
 }
 
 DEFINE_PRIMITIVE(callstack_to_array)
@@ -429,7 +428,12 @@ DEFINE_PRIMITIVE(callstack_to_array)
 
 	/* frame_count is equal to the total length now */
 
+#ifdef CALLSTACK_UP_P
 	frame_index = 0;
+#else
+	frame_index = frame_count - 1;
+#endif
+
 	iterate_callstack_object(stack,stack_frame_to_array);
 
 	dpush(tag_object(array));

vm/types.c

@@ -131,12 +131,8 @@ DEFINE_PRIMITIVE(array_to_quotation)
 {
 	F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
 	quot->array = dpeek();
-	quot->xt = NULL;
-
-	REGISTER_UNTAGGED(quot);
-	jit_compile(quot);
-	UNREGISTER_UNTAGGED(quot);
-
+	quot->xt = lazy_jit_compile;
+	quot->compiled = F;
 	drepl(tag_object(quot));
 }
 
@@ -482,7 +478,8 @@ F_WORD *allot_word(CELL vocab, CELL name)
 	word->def = F;
 	word->props = F;
 	word->counter = tag_fixnum(0);
-	update_xt(word);
+	word->compiledp = F;
+	word->xt = default_word_xt(word);
 	return word;
 }
 
@@ -495,7 +492,9 @@ DEFINE_PRIMITIVE(word)
 
 DEFINE_PRIMITIVE(update_xt)
 {
-	update_xt(untag_word(dpop()));
+	F_WORD *word = untag_word(dpop());
+	word->compiledp = F;
+	word->xt = default_word_xt(word);
 }
 
 DEFINE_PRIMITIVE(word_xt)