diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index f8258039e1..7b56bd6150 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/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 ) - 2drop 0 ; +: relevant-ranges ( new inactive -- new' inactive' ) + ! 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 -- ) diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index e4510e884e..ccfc4a1ff7 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/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 \ No newline at end of file diff --git a/basis/json/reader/authors.txt b/basis/json/reader/authors.txt index 44b06f94bc..d269b4ffb5 100644 --- a/basis/json/reader/authors.txt +++ b/basis/json/reader/authors.txt @@ -1 +1,3 @@ Chris Double +Peter Burns +Philipp Winkler diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor index e97d45babe..14a54b89c0 100644 --- a/basis/json/reader/reader-tests.factor +++ b/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 diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index 887a7a50e5..9886e316d7 100644 --- a/basis/json/reader/reader.factor +++ b/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 -math.functions sequences arrays vectors hashtables assocs -prettyprint json ; +USING: arrays assocs combinators io io.streams.string json +kernel math math.parser math.parser.private prettyprint +sequences strings vectors ; IN: json.reader 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 -EBNF: (json>) +: third-last ( seq -- third-last ) + [ 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 ]] -false = "false" => [[ f ]] -null = "null" => [[ json-null ]] +: v-over-push ( vec -- vec' ) + dup length 2 >= + [ + dup + [ pop ] + [ last ] bi push + ] when ; -hex = [0-9a-fA-F] -char = '\\"' [[ CHAR: " ]] - | "\\\\" [[ CHAR: \ ]] - | "\\/" [[ CHAR: / ]] - | "\\b" [[ 8 ]] - | "\\f" [[ 12 ]] - | "\\n" [[ CHAR: \n ]] - | "\\r" [[ CHAR: \r ]] - | "\\t" [[ CHAR: \t ]] - | "\\u" (hex hex hex hex) [[ hex> ]] => [[ second ]] - | [^"\] -string = '"' char*:cs '"' => [[ cs >string ]] +: v-pick-push ( vec -- vec' ) + dup length 3 >= + [ + dup + [ pop ] + [ second-last ] bi push + ] when ; -sign = ("-" | "+")? => [[ "-" = "-" "" ? ]] -digits = [0-9]+ => [[ >string ]] -decimal = "." digits => [[ concat ]] -exp = ("e" | "E") sign digits => [[ concat ]] -number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]] +: (close-array) ( accum -- accum' ) + dup last vector? [ v-over-push ] unless + dup pop >array over push ; -elements = value ("," value)* => [[ grammar-list>vector ]] -array = "[" elements?:arr "]" => [[ arr >array ]] - -pair = ws string:key ws ":" value:val => [[ { key val } ]] -members = pair ("," pair)* => [[ grammar-list>vector ]] -object = "{" members?:hash "}" => [[ hash >hashtable ]] - -val = true - | false - | null - | string - | number - | array - | object - -value = ws val:v ws => [[ v ]] - -;EBNF +: (close-hash) ( accum -- accum' ) + dup length 3 >= [ v-over-push ] when + dup dup [ pop ] dip pop swap + zip H{ } assoc-clone-like over push ; + +: scan ( accum char -- accum ) + ! 2dup . . ! Great for debug... + [ + { + { CHAR: \" [ j-string over push ] } + { CHAR: [ [ V{ } clone over push ] } + { CHAR: , [ v-over-push ] } + { CHAR: ] [ (close-array) ] } + { CHAR: { [ 2 [ V{ } clone over push ] times ] } + { CHAR: : [ v-pick-push ] } + { CHAR: } [ (close-hash) ] } + { CHAR: \u000020 [ ] } + { 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>) ; \ No newline at end of file + +: json> ( string -- object ) + (json-parser>) ; \ No newline at end of file diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index b302fb6b8f..cc8ebe35fb 100644 --- a/misc/fuel/factor-mode.el +++ b/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." diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 80fe8e830b..cc788fe5dc 100644 --- a/misc/fuel/fuel-markup.el +++ b/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)) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 0186392f34..282ef3240f 100644 --- a/misc/fuel/fuel-mode.el +++ b/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: diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el index b1c4462503..9b7d9861c7 100644 --- a/misc/fuel/fuel-scaffold.el +++ b/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) - "fuel")) - (ret (fuel-eval--send/wait cmd)) + (ret (fuel-scaffold--create-docs vocab)) (file (fuel-eval--retort-result ret))) (unless file (error "Error creating help file" (car (fuel-eval--retort-error ret)))) diff --git a/misc/fuel/fuel-table.el b/misc/fuel/fuel-table.el index a00b21bf2f..1af2e25712 100644 --- a/misc/fuel/fuel-table.el +++ b/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)) - (ls (concat "+" (mapconcat (lambda (n) (make-string n ?-)) widths "-+") "-+"))) - (insert ls "\n") + (rows (fuel-table--format-rows rows widths))) + (fuel-table--insert-first-line widths) (dolist (r rows) - (let ((ln (length (car r))) - (l 0)) - (while (< l ln) - (insert (concat "|" (mapconcat 'identity - (mapcar `(lambda (x) (nth ,l x)) r) - " |") - " |\n")) - (setq l (1+ l)))) - (insert ls "\n")))) + (fuel-table--insert-row r) + (fuel-table--insert-middle-line widths)) + (kill-line -1) + (fuel-table--insert-last-line widths))) (provide 'fuel-table)