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

basis/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -226,18 +226,41 @@ SYMBOL: spill-counts
 : assign-free-register ( new registers -- )
     pop >>reg add-active ;
 
-: next-intersection ( new inactive -- n )
+: relevant-ranges ( new inactive -- new' inactive' )
-    2drop 0 ;
+    ! Slice off all ranges of 'inactive' that precede the start of 'new'
+    [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
+
+: intersect-live-range ( range1 range2 -- n/f )
+    2dup [ from>> ] bi@ > [ swap ] when
+    2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
+
+: intersect-live-ranges ( ranges1 ranges2 -- n )
+    {
+        { [ over empty? ] [ 2drop 1/0. ] }
+        { [ dup empty? ] [ 2drop 1/0. ] }
+        [
+            2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
+                drop
+                2dup [ first from>> ] bi@ <
+                [ [ rest-slice ] dip ] [ rest-slice ] if
+                intersect-live-ranges
+            ] if
+        ]
+    } cond ;
+
+: intersect-inactive ( new inactive -- n )
+    relevant-ranges intersect-live-ranges ;
 
 : intersecting-inactive ( new -- live-intervals )
     dup vreg>> inactive-intervals-for
-    [ tuck next-intersection ] with { } map>assoc ;
+    [ tuck intersect-inactive ] with { } map>assoc ;
 
 : fits-in-hole ( new pair -- )
     first reuse-register ;
 
 : split-before-use ( new pair -- before after )
     ! Find optimal split position
+    ! Insert move instruction
     second split-interval ;
 
 : assign-inactive-register ( new live-intervals -- )

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -1314,4 +1314,64 @@ USING: math.private compiler.cfg.debugger ;
        }
     } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
     instructions>> first live-spill-slots>> empty?
+] unit-test
+
+[ f ] [
+    T{ live-range f 0 10 }
+    T{ live-range f 20 30 }
+    intersect-live-range
+] unit-test
+
+[ 10 ] [
+    T{ live-range f 0 10 }
+    T{ live-range f 10 30 }
+    intersect-live-range
+] unit-test
+
+[ 5 ] [
+    T{ live-range f 0 10 }
+    T{ live-range f 5 30 }
+    intersect-live-range
+] unit-test
+
+[ 5 ] [
+    T{ live-range f 5 30 }
+    T{ live-range f 0 10 }
+    intersect-live-range
+] unit-test
+
+[ 5 ] [
+    T{ live-range f 5 10 }
+    T{ live-range f 0 15 }
+    intersect-live-range
+] unit-test
+
+[ 50 ] [
+    {
+        T{ live-range f 0 10 }
+        T{ live-range f 20 30 }
+        T{ live-range f 40 50 }
+    }
+    {
+        T{ live-range f 11 15 }
+        T{ live-range f 31 35 }
+        T{ live-range f 50 55 }
+    }
+    intersect-live-ranges
+] unit-test
+
+[ 5 ] [
+    T{ live-interval
+       { start 0 }
+       { end 10 }
+       { uses { 0 10 } }
+       { ranges V{ T{ live-range f 0 10 } } }
+    }
+    T{ live-interval
+       { start 5 }
+       { end 10 }
+       { uses { 5 10 } }
+       { ranges V{ T{ live-range f 5 10 } } }
+    }
+    intersect-inactive
 ] unit-test

basis/json/reader/authors.txt

@@ -1 +1,3 @@
 Chris Double
+Peter Burns
+Philipp Winkler

basis/json/reader/reader-tests.factor

@@ -19,6 +19,8 @@ IN: json.reader.tests
 { 10.25 } [ "1025e-2" json> ] unit-test
 { 0.125 } [ "0.125" json> ] unit-test
 { -0.125 } [ "-0.125" json> ] unit-test
+{ -0.00125 } [ "-0.125e-2" json> ] unit-test
+{ -012.5 } [ "-0.125e+2" json> ] unit-test
 
 ! not widely supported by javascript, but allowed in the grammar, and a nice
 ! feature to get
@@ -31,6 +33,7 @@ IN: json.reader.tests
 { 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
 { HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
 
+{ H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test
 { { } } [ "[]" json> ] unit-test 
 { { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
 { H{ } } [ "{}" json> ] unit-test

basis/json/reader/reader.factor

@@ -1,61 +1,103 @@
-! Copyright (C) 2008 Peter Burns.
+! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf math.parser math.parser.private strings math
+USING: arrays assocs combinators io io.streams.string json
-math.functions sequences arrays vectors hashtables assocs
+kernel math math.parser math.parser.private prettyprint
-prettyprint json ;
+sequences strings vectors ;
 IN: json.reader
 
 <PRIVATE
+: value ( char -- num char )
+    1string " \t\r\n,:}]" read-until
+    [
+        append
+        [ string>float ]
+        [ [ "eE." index ] any? [ >integer ] unless ] bi
+    ] dip ;
 
-: grammar-list>vector ( seq -- vec ) first2 values swap prefix ;
+DEFER: j-string
+    
+: convert-string ( str -- str )
+    read1
+    {
+        { CHAR: b [ 8 ] }
+        { CHAR: f [ 12 ] }
+        { CHAR: n [ CHAR: \n ] }
+        { CHAR: r [ CHAR: \r ] }
+        { CHAR: t [ CHAR: \t ] }
+        { CHAR: u [ 4 read hex> ] }
+        [ ]
+    } case
+    dup
+    [ 1string append j-string append ]
+    [ drop ] if ;
+    
+: j-string ( -- str )
+    "\\\"" read-until CHAR: \" =
+    [ convert-string ] unless ;
+    
+: second-last ( seq -- second-last )
+    [ length 2 - ] keep nth ; inline
 
-! Grammar for JSON from RFC 4627
+: third-last ( seq -- third-last )
-EBNF: (json>)
+    [ length 3 - ] keep nth ; inline
+    
+: last2 ( seq -- second-last last )
+    [ second-last ] [ last ] bi ; inline
 
-ws = (" " | "\r" | "\t" | "\n")*
+: last3 ( seq -- third-last second-last last )
+    [ third-last ] [ last2 ] bi ; inline
 
-true = "true" => [[ t ]]
+: v-over-push ( vec -- vec' )
-false = "false" => [[ f ]]
+    dup length 2 >=
-null = "null" => [[ json-null ]]
+    [
+        dup
+        [ pop ]
+        [ last ] bi push
+    ] when ;
 
-hex = [0-9a-fA-F]
+: v-pick-push ( vec -- vec' )
-char = '\\"'  [[ CHAR: "  ]]
+    dup length 3 >=
-     | "\\\\" [[ CHAR: \  ]]
+    [
-     | "\\/"  [[ CHAR: /  ]]
+        dup
-     | "\\b"  [[ 8        ]]
+        [ pop ]
-     | "\\f"  [[ 12       ]]
+        [ second-last ] bi push
-     | "\\n"  [[ CHAR: \n ]]
+    ] when ;
-     | "\\r"  [[ CHAR: \r ]]
-     | "\\t"  [[ CHAR: \t ]]
-     | "\\u" (hex hex hex hex) [[ hex> ]] => [[ second ]]
-     | [^"\]
-string = '"' char*:cs '"' => [[ cs >string ]]
 
-sign = ("-" | "+")? => [[ "-" = "-" "" ? ]]
+: (close-array) ( accum -- accum' )
-digits = [0-9]+     => [[ >string ]]
+    dup last vector? [ v-over-push ] unless
-decimal = "." digits  => [[ concat ]]
+    dup pop >array over push ;
-exp = ("e" | "E") sign digits => [[ concat ]]
-number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]]
 
-elements = value ("," value)* => [[ grammar-list>vector ]]
+: (close-hash) ( accum -- accum' )
-array = "[" elements?:arr "]" => [[ arr >array ]]
+    dup length 3 >= [ v-over-push ] when
-
+    dup dup [ pop ] dip pop swap
-pair = ws string:key ws ":" value:val => [[ { key val } ]]
+    zip H{ } assoc-clone-like over push ;
-members = pair ("," pair)* => [[ grammar-list>vector ]]
+                                                 
-object = "{" members?:hash "}" => [[ hash >hashtable ]]
+: scan ( accum char -- accum )
-
+    ! 2dup . . ! Great for debug...
-val = true
+    [
-    | false
+        {
-    | null
+            { CHAR: \" [ j-string over push ] }
-    | string
+            { CHAR: [  [ V{ } clone over push ] }
-    | number
+            { CHAR: ,  [ v-over-push ] }
-    | array
+            { CHAR: ]  [ (close-array) ] }
-    | object
+            { CHAR: {  [ 2 [ V{ } clone over push ] times ] }
-
+            { CHAR: :  [ v-pick-push ] }
-value = ws val:v ws => [[ v ]]
+            { CHAR: }  [ (close-hash) ] }
-
+            { CHAR: \u000020 [ ] }
-;EBNF
+            { CHAR: \t [ ] }
+            { CHAR: \r [ ] }
+            { CHAR: \n [ ] }
+            { CHAR: t  [ 3 read drop t over push ] }
+            { CHAR: f  [ 4 read drop f over push ] }
+            { CHAR: n  [ 3 read drop json-null over push ] }
+            [ value [ over push ] dip [ scan ] when*  ]
+        } case 
+    ] when* ;
 
+: (json-parser>) ( string -- object )
+    [ V{ } clone [ read1 dup ] [ scan ] while drop first ] with-string-reader ;
+    
 PRIVATE>
-
+    
-: json> ( string -- object ) (json>) ;
+: json> ( string -- object )
+    (json-parser>) ;

misc/fuel/factor-mode.el

@@ -125,7 +125,8 @@ code in the buffer."
 (defun factor-mode--indent-setter-line ()
   (when (fuel-syntax--at-setter-line)
     (save-excursion
-      (let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation))))
+      (let ((indent (and (fuel-syntax--at-constructor-line)
+                         (current-indentation))))
         (while (not (or indent
                         (bobp)
                         (fuel-syntax--at-begin-of-def)
@@ -225,6 +226,19 @@ code in the buffer."
 (defsubst factor-mode--cycling-setup ()
   (setq factor-mode--cycling-no-ask nil))
 
+(defun factor-mode--code-file (kind &optional file)
+  (let* ((file (or file (buffer-file-name)))
+         (bn (file-name-nondirectory file)))
+    (and (string-match (format "\\(.+\\)-%s\\.factor$" kind) bn)
+         (expand-file-name (concat (match-string 1 bn) ".factor")
+                           (file-name-directory file)))))
+
+(defsubst factor-mode--in-docs (&optional file)
+  (factor-mode--code-file "docs"))
+
+(defsubst factor-mode--in-tests (&optional file)
+  (factor-mode--code-file "tests"))
+
 (defun factor-mode-visit-other-file (&optional skip)
   "Cycle between code, tests and docs factor files.
 With prefix, non-existing files will be skipped."

misc/fuel/fuel-markup.el

@@ -382,7 +382,7 @@
         (when (looking-at "Word *\\(Stack effect\\|Syntax\\)$")
           (push (list "Word" (match-string-no-properties 1)) rows)
           (forward-line))
-        (while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$")
+        (while (looking-at " ?\\(.+?\\)\\( +\\(.+\\)\\)?$")
           (let ((word `($link ,(match-string-no-properties 1)
                               ,(match-string-no-properties 1)
                               word))

misc/fuel/fuel-mode.el

@@ -172,7 +172,10 @@ interacting with a factor listener is at your disposal.
   (when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode))
 
   (setq fuel-stack-mode-string "/S")
-  (when fuel-mode-stack-p (fuel-stack-mode fuel-mode)))
+  (when fuel-mode-stack-p (fuel-stack-mode fuel-mode))
+
+  (when (and fuel-mode (not (file-exists-p (buffer-file-name))))
+    (fuel-scaffold--maybe-insert)))
 
 
 ;;; Keys:

misc/fuel/fuel-scaffold.el

@@ -39,6 +39,64 @@
   (let ((cmd '(:fuel* (vocab-roots get :get) "fuel")))
     (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
 
+(defun fuel-scaffold--dev-name ()
+  (or fuel-scaffold-developer-name
+      (let ((cmd '(:fuel* (developer-name get :get) "fuel")))
+        (fuel-eval--retort-result (fuel-eval--send/wait cmd)))
+      "Your name"))
+
+(defun fuel-scaffold--first-vocab ()
+  (goto-char (point-min))
+  (re-search-forward fuel-syntax--current-vocab-regex nil t))
+
+(defsubst fuel-scaffold--vocab (file)
+  (save-excursion
+    (set-buffer (find-file-noselect file))
+    (fuel-scaffold--first-vocab)
+    (fuel-syntax--current-vocab)))
+
+(defconst fuel-scaffold--tests-header-format
+  "! Copyright (C) %s %s
+! See http://factorcode.org/license.txt for BSD license.
+USING: %s tools.test ;
+IN: %s
+")
+
+(defsubst fuel-scaffold--check-auto (var)
+  (and var (or (eq var 'always) (y-or-n-p "Insert template? "))))
+
+(defun fuel-scaffold--tests (parent)
+  (when (and parent (fuel-scaffold--check-auto fuel-scaffold-test-autoinsert-p))
+    (let ((year (format-time-string "%Y"))
+          (name (fuel-scaffold--dev-name))
+          (vocab (fuel-scaffold--vocab parent)))
+      (insert (format fuel-scaffold--tests-header-format
+                      year name vocab vocab))
+      t)))
+
+(defsubst fuel-scaffold--create-docs (vocab)
+  (let ((cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
+                      "fuel")))
+    (fuel-eval--send/wait cmd)))
+
+(defun fuel-scaffold--help (parent)
+  (when (and parent (fuel-scaffold--check-auto fuel-scaffold-help-autoinsert-p))
+    (let* ((ret (fuel-scaffold--create-docs (fuel-scaffold--vocab parent)))
+           (file (fuel-eval--retort-result ret)))
+      (when file
+        (revert-buffer t t t)
+        (when (and fuel-scaffold-help-header-only-p
+                   (fuel-scaffold--first-vocab))
+          (delete-region (1+ (point)) (point-max))
+          (save-buffer))
+        (message "Inserting template ... done."))
+      (goto-char (point-min)))))
+
+(defun fuel-scaffold--maybe-insert ()
+  (ignore-errors
+    (or (fuel-scaffold--tests (factor-mode--in-tests))
+        (fuel-scaffold--help (factor-mode--in-docs)))))
+
 
 ;;; User interface:
 
@@ -73,9 +131,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to
   (interactive "P")
   (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
                     (fuel-completion--read-vocab nil)))
-         (cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
+         (ret (fuel-scaffold--create-docs vocab))
-                       "fuel"))
-         (ret (fuel-eval--send/wait cmd))
          (file (fuel-eval--retort-result ret)))
         (unless file
           (error "Error creating help file" (car (fuel-eval--retort-error ret))))

misc/fuel/fuel-table.el

@@ -72,21 +72,67 @@
         (push (fuel-table--pad-row (reverse frow)) frows)))
     (reverse frows)))
 
+(defvar fuel-table-corner-lt "┌")
+(defvar fuel-table-corner-lb "└")
+(defvar fuel-table-corner-rt "┐")
+(defvar fuel-table-corner-rb "┘")
+(defvar fuel-table-line "─")
+(defvar fuel-table-tee-t "┬")
+(defvar fuel-table-tee-b "┴")
+(defvar fuel-table-tee-l "├")
+(defvar fuel-table-tee-r "┤")
+(defvar fuel-table-crux "┼")
+(defvar fuel-table-sep "│")
+
+(defun fuel-table--insert-line (widths first last sep)
+  (insert first fuel-table-line)
+  (dolist (w widths)
+    (while (> w 0)
+      (insert fuel-table-line)
+      (setq w (1- w)))
+    (insert fuel-table-line sep fuel-table-line))
+  (delete-char -2)
+  (insert fuel-table-line last)
+  (newline))
+
+(defun fuel-table--insert-first-line (widths)
+  (fuel-table--insert-line widths
+                           fuel-table-corner-lt
+                           fuel-table-corner-rt
+                           fuel-table-tee-t))
+
+(defun fuel-table--insert-middle-line (widths)
+  (fuel-table--insert-line widths
+                           fuel-table-tee-l
+                           fuel-table-tee-r
+                           fuel-table-crux))
+
+(defun fuel-table--insert-last-line (widths)
+  (fuel-table--insert-line widths
+                           fuel-table-corner-lb
+                           fuel-table-corner-rb
+                           fuel-table-tee-b))
+
+(defun fuel-table--insert-row (r)
+  (let ((ln (length (car r)))
+        (l 0))
+    (while (< l ln)
+      (insert (concat fuel-table-sep " "
+                      (mapconcat 'identity
+                                 (mapcar `(lambda (x) (nth ,l x)) r)
+                                 (concat " " fuel-table-sep " "))
+                      "  " fuel-table-sep "\n"))
+      (setq l (1+ l)))))
+
 (defun fuel-table--insert (rows)
   (let* ((widths (fuel-table--col-widths rows))
-         (rows (fuel-table--format-rows rows widths))
+         (rows (fuel-table--format-rows rows widths)))
-         (ls (concat "+" (mapconcat (lambda (n) (make-string n ?-)) widths "-+") "-+")))
+    (fuel-table--insert-first-line widths)
-    (insert ls "\n")
     (dolist (r rows)
-      (let ((ln (length (car r)))
+      (fuel-table--insert-row r)
-            (l 0))
+      (fuel-table--insert-middle-line widths))
-        (while (< l ln)
+    (kill-line -1)
-          (insert (concat "|" (mapconcat 'identity
+    (fuel-table--insert-last-line widths)))
-                                         (mapcar `(lambda (x) (nth ,l x)) r)
-                                         " |")
-                          " |\n"))
-          (setq l (1+ l))))
-      (insert ls "\n"))))
 
 
 (provide 'fuel-table)