steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2009-06-07 21:46:41 -05:00
parent 9ad9600764 16f144af58
commit 4fbe99400f
10 changed files with 318 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -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 -- )

60
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -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

2
basis/json/reader/authors.txt
View File

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

3
basis/json/reader/reader-tests.factor
View File

@ -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

138
basis/json/reader/reader.factor
View File

@ -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
<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
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>) ;
: json> ( string -- object )
(json-parser>) ;

16
misc/fuel/factor-mode.el
View File

@ -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."

2
misc/fuel/fuel-markup.el
View File

@ -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))

5
misc/fuel/fuel-mode.el
View File

@ -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:

62
misc/fuel/fuel-scaffold.el
View File

@ -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))))

70
misc/fuel/fuel-table.el
View File

@ -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)