Merge branch 'master' into semantic-db

core/prettyprint/prettyprint.factor

@@ -174,7 +174,7 @@ M: hook-generic synopsis*
     dup definer.
     dup seeing-word
     dup pprint-word
-    dup "combination" word-prop hook-combination-var pprint-word
+    dup "combination" word-prop hook-combination-var pprint*
     stack-effect. ;
 
 M: method-spec synopsis*

extra/builder/builder.factor

@@ -61,6 +61,17 @@ VAR: stamp
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: copy-image ( -- )
+  "../../factor/" my-boot-image-name append
+  "../"           my-boot-image-name append
+  copy-file
+
+  "../../factor/" my-boot-image-name append
+                  my-boot-image-name
+  copy-file ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : factor-binary ( -- name )
   os
   { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
@@ -69,8 +80,7 @@ VAR: stamp
   case ;
 
 : bootstrap-cmd ( -- cmd )
-  { factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" }
+  { factor-binary { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
-  to-strings ;
 
 : bootstrap ( -- desc )
   <process*>
@@ -81,7 +91,48 @@ VAR: stamp
     20 minutes>ms >>timeout
   >desc ;
 
-: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ;
+: builder-test-cmd ( -- cmd )
+  { factor-binary "-run=builder.test" } to-strings ;
+
+: builder-test ( -- desc )
+  <process*>
+    builder-test-cmd >>arguments
+    +closed+         >>stdin
+    "../test-log"    >>stdout
+    +stdout+         >>stderr
+    45 minutes>ms    >>timeout
+  >desc ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: arrays assocs math ;
+
+: passing-benchmarks ( table -- table )
+  [ second first2 number? swap number? and ] subset ;
+
+: simplify-table ( table -- table ) [ first2 second 2array ] map ;
+
+: benchmark-difference ( old-table benchmark-result -- result-diff )
+  first2 >r
+  tuck swap at
+  r>
+  swap -
+  2array ;
+
+: compare-tables ( old new -- table )
+  [ passing-benchmarks simplify-table ] 2apply
+  [ benchmark-difference ] with map ;
+
+: show-benchmark-deltas ( -- )
+  "Benchmark deltas: " print
+
+  [
+    "../../benchmarks" eval-file
+    "../benchmarks"    eval-file
+    compare-tables .
+  ]
+    [ drop "Error generating benchmark deltas" . ]
+  recover ;
   
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -112,13 +163,13 @@ SYMBOL: build-status
 
     make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
 
-    [ retrieve-image ] [ "Image download error" print throw ] recover
+    ! [ retrieve-image ] [ "Image download error" print throw ] recover
+
+    copy-image
 
     bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
 
-    [ builder-test try-process ]
+    builder-test [ "Test error" print "../test-log" cat ] run-or-bail
-    [ "Builder test error" print throw ]
-    recover
 
     "Boot time: " write "../boot-time" eval-file milli-seconds>time print
     "Load time: " write "../load-time" eval-file milli-seconds>time print
@@ -130,6 +181,12 @@ SYMBOL: build-status
     "Benchmarks: " print
     "../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks.
 
+    nl
+    
+    show-benchmark-deltas
+
+    "../benchmarks" "../../benchmarks" copy-file    
+
   ] with-file-writer
 
   build-status on ;
@@ -152,12 +209,17 @@ SYMBOL: builder-recipients
     "../report" file>string >>body
   send ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : build ( -- )
   [ (build) ] [ drop ] recover
-  [ send-builder-email ] [ drop "not sending mail" . ] recover ;
+  [ send-builder-email ] [ drop "not sending mail" . ] recover
+  ".." cd { "rm" "-rf" "factor" } run-process drop ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+USE: bootstrap.image.download
+
 : git-pull ( -- desc )
   {
     "git"
@@ -173,11 +235,17 @@ SYMBOL: builder-recipients
   git-id
   = not ;
 
+: new-image-available? ( -- ? )
+  my-boot-image-name need-new-image?
+    [ download-my-image t ]
+    [ f ]
+  if ;
+
 : build-loop ( -- )
   builds-check
   [
     builds "/factor" append cd
-    updates-available?
+    updates-available? new-image-available? or
       [ build ]
     when
   ]

misc/factor.el

@@ -110,8 +110,8 @@
 
 (require 'comint)
 
-(defvar factor-binary "/scratch/repos/Factor/factor")
+(defvar factor-binary "~/factor/factor")
-(defvar factor-image "/scratch/repos/Factor/factor.image")
+(defvar factor-image "~/factor/factor.image")
 
 (defun factor-telnet-to-port (port)
   (interactive "nPort: ")
@@ -202,8 +202,8 @@
 (defun run-factor ()
   (interactive)
   (switch-to-buffer
-   (make-comint-in-buffer "factor" nil factor-binary nil
+   (make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil
-			  (concat "-i=" factor-image)
+			  (concat "-i=" (expand-file-name factor-image))
 			  "-run=listener"))
   (factor-listener-mode))