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

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

db4
John Benediktsson 2008-11-23 20:41:44 -08:00
parent 2196d99b9b 915bf0c449
commit cf6fc05527
10 changed files with 170 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/tests/optimizer.factor
View File

@ -286,9 +286,7 @@ HINTS: recursive-inline-hang-2 array ;
HINTS: recursive-inline-hang-3 array ;
! Regression
USE: sequences.private
[ ] [ { (3append) } compile ] unit-test
[ ] [ { 3append-as } compile ] unit-test
! Wow
: counter-example ( a b c d -- a' b' c' d' )

47
basis/sequences/deep/deep-docs.factor
View File

@ -1,30 +1,49 @@
USING: help.syntax help.markup ;
USING: help.syntax help.markup kernel sequences ;
IN: sequences.deep
HELP: deep-each
{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ) " } }
{ $description "Execute a quotation on each nested element of an object and its children, in preorder." } ;
{ $values { "obj" object } { "quot" { $quotation "( elt -- )" } } }
{ $description "Execute a quotation on each nested element of an object and its children, in preorder." }
{ $see-also each } ;
HELP: deep-map
{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } { "newobj" "the mapped object" } }
{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } ;
{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } { "newobj" "the mapped object" } }
{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." }
{ $see-also map } ;
HELP: deep-filter
{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "seq" "a sequence" } }
{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } ;
{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "seq" "a sequence" } }
{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." }
{ $see-also filter } ;
HELP: deep-find
{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "elt" "an element" } }
{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } ;
{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "elt" "an element" } }
{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." }
{ $see-also find } ;
HELP: deep-contains?
{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "?" "a boolean" } }
{ $description "Tests whether the given object or any subnode satisfies the given quotation." } ;
{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests whether the given object or any subnode satisfies the given quotation." }
{ $see-also contains? } ;
HELP: flatten
{ $values { "obj" "an object" } { "seq" "a sequence" } }
{ $values { "obj" object } { "seq" "a sequence" } }
{ $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ;
HELP: deep-change-each
{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } }
{ $description "Modifies each sub-node of an object in place, in preorder." } ;
{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } }
{ $description "Modifies each sub-node of an object in place, in preorder." }
{ $see-also change-each } ;
ARTICLE: "sequences.deep" "Deep sequence combinators"
"The combinators in the " { $vocab-link "sequences.deep" } " vocabulary are variants of standard sequence combinators which traverse nested subsequences."
{ $subsection deep-each }
{ $subsection deep-map }
{ $subsection deep-filter }
{ $subsection deep-find }
{ $subsection deep-contains? }
{ $subsection deep-change-each }
"A utility word to collapse nested subsequences:"
{ $subsection flatten } ;
ABOUT: "sequences.deep"

19
basis/sequences/deep/deep.factor
View File

@ -21,28 +21,27 @@ M: object branch? drop f ;
[ [ deep-map ] curry map ] [ drop ] if ; inline recursive
: deep-filter ( obj quot: ( elt -- ? ) -- seq )
over >r
pusher >r deep-each r>
r> dup branch? [ like ] [ drop ] if ; inline recursive
over [ pusher [ deep-each ] dip ] dip
dup branch? [ like ] [ drop ] if ; inline recursive
: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? )
: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
f -rot [ [ nip ] dip (deep-find) ] curry find drop >boolean
] [ 2drop f f ] if
] if ; inline recursive
: deep-find ( obj quot -- elt ) deep-find-from drop ; inline
: deep-find ( obj quot -- elt ) (deep-find) drop ; inline
: deep-contains? ( obj quot -- ? ) deep-find-from nip ; inline
: deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
: deep-change-each ( obj quot: ( elt -- elt' ) -- )
over branch? [ [
[ call ] keep over >r deep-change-each r>
] curry change-each ] [ 2drop ] if ; inline recursive
over branch? [
[ [ call ] keep over [ deep-change-each ] dip ] curry change-each
] [ 2drop ] if ; inline recursive
: flatten ( obj -- seq )
[ branch? not ] deep-filter ;

6
basis/tools/walker/walker-tests.factor
View File

@ -17,7 +17,11 @@ IN: tools.walker.tests
] unit-test
[ { "Yo" 2 } ] [
[ 2 >r "Yo" r> ] test-walker
[ 2 [ "Yo" ] dip ] test-walker
] unit-test
[ { "Yo" 2 3 } ] [
[ 2 [ "Yo" ] dip 3 ] test-walker
] unit-test
[ { 2 } ] [

48
basis/tools/walker/walker.factor
View File

@ -64,6 +64,12 @@ M: object add-breakpoint ;
: (step-into-quot) ( quot -- ) add-breakpoint call ;
: (step-into-dip) ( quot -- ) add-breakpoint dip ;
: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
@ -103,25 +109,25 @@ SYMBOL: +stopped+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
>r clone r> [
>r clone r>
[ clone ] dip [
[ clone ] dip
[
>r
[ innermost-frame-scan 1+ ]
[ innermost-frame-quot ] bi
r> call
[
[ innermost-frame-scan 1+ ]
[ innermost-frame-quot ] bi
] dip call
]
[ drop set-innermost-frame-quot ]
[ drop ]
2tri
] curry change-call ; inline
: step-msg ( continuation -- continuation' )
: step-msg ( continuation -- continuation' ) USE: io
[
2dup nth \ break = [
nip
] [
swap 1+ cut [ break ] swap 3append
2dup length = [ nip [ break ] append ] [
2dup nth \ break = [ nip ] [
swap 1+ cut [ break ] swap 3append
] if
] if
] change-frame ;
@ -130,6 +136,9 @@ SYMBOL: +stopped+
{
{ call [ (step-into-quot) ] }
{ dip [ (step-into-dip) ] }
{ 2dip [ (step-into-2dip) ] }
{ 3dip [ (step-into-3dip) ] }
{ (throw) [ drop (step-into-quot) ] }
{ execute [ (step-into-execute) ] }
{ if [ (step-into-if) ] }
@ -152,13 +161,16 @@ SYMBOL: +stopped+
: step-into-msg ( continuation -- continuation' )
[
swap cut [
swap % unclip {
{ [ dup \ break eq? ] [ , ] }
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
{ [ dup array? ] [ add-breakpoint , \ break , ] }
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
[ , \ break , ]
} cond %
swap %
[ \ break , ] [
unclip {
{ [ dup \ break eq? ] [ , ] }
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
{ [ dup array? ] [ add-breakpoint , \ break , ] }
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
[ , \ break , ]
} cond %
] if-empty
] [ ] make
] change-frame ;

41
core/kernel/kernel-tests.factor
View File

@ -1,7 +1,7 @@
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs
sequences.private ;
sequences.private accessors ;
IN: kernel.tests
[ 0 ] [ f size ] unit-test
@ -124,3 +124,42 @@ IN: kernel.tests
[ [ sq ] tri@ ] must-infer
[ 4 ] [ 1 { [ 1 ] [ 2 ] } dispatch sq ] unit-test
! Test traceback accuracy
: last-frame ( -- pair )
error-continuation get call>> callstack>array 4 head* 2 tail* ;
[
{ [ 1 2 [ 3 throw ] call 4 ] 3 }
] [
[ [ 1 2 [ 3 throw ] call 4 ] call ] ignore-errors
last-frame
] unit-test
[
{ [ 1 2 [ 3 throw ] dip 4 ] 3 }
] [
[ [ 1 2 [ 3 throw ] dip 4 ] call ] ignore-errors
last-frame
] unit-test
[
{ [ 1 2 3 throw [ ] call 4 ] 3 }
] [
[ [ 1 2 3 throw [ ] call 4 ] call ] ignore-errors
last-frame
] unit-test
[
{ [ 1 2 3 throw [ ] dip 4 ] 3 }
] [
[ [ 1 2 3 throw [ ] dip 4 ] call ] ignore-errors
last-frame
] unit-test
[
{ [ 1 2 3 throw [ ] [ ] if 4 ] 3 }
] [
[ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors
last-frame
] unit-test

2
extra/mason/test/test.factor
View File

@ -47,7 +47,7 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
".." [
bootstrap-time get boot-time-file to-file
[ do-load do-compile-errors ] benchmark-ms load-time-file to-file
[ generate-help ] html-help-time-file to-file
[ generate-help ] benchmark-ms html-help-time-file to-file
[ do-tests ] benchmark-ms test-time-file to-file
[ do-help-lint ] benchmark-ms help-lint-time-file to-file
[ do-benchmarks ] benchmark-ms benchmark-time-file to-file

2
extra/wordtimer/wordtimer.factor
View File

@ -1,6 +1,6 @@
USING: kernel sequences namespaces make math assocs words arrays
tools.annotations vocabs sorting prettyprint io system
math.statistics accessors ;
math.statistics accessors tools.time ;
IN: wordtimer
SYMBOL: *wordtimes*

66
misc/factor.el
View File

@ -162,6 +162,10 @@ buffer."
;;; Factor mode font lock:
(defconst factor--regexp-word-start
(let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
(format "^\\(%s\\)\\(:\\) " (mapconcat 'identity sws "\\|"))))
(defconst factor--parsing-words
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
@ -201,12 +205,7 @@ buffer."
(defconst factor--regex-use-line "^USE: +\\(.*\\)$")
(defconst factor-font-lock-keywords
`(("#!.*$" . 'factor-font-lock-comment)
("!( .* )" . 'factor-font-lock-comment)
("^!.*$" . 'factor-font-lock-comment)
(" !.*$" . 'factor-font-lock-comment)
("( .* )" . 'factor-font-lock-stack-effect)
("\"\\(\\\\\"\\|[^\"]\\)*\"" . 'factor-font-lock-string)
`(("( .* )" . 'factor-font-lock-stack-effect)
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
'(2 'factor-font-lock-parsing-word)))
@ -225,6 +224,14 @@ buffer."
;;; Factor mode syntax:
(defconst factor--font-lock-syntactic-keywords
`(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;"))
(,factor--regexp-word-start (2 "(;"))
("\\(;\\)" (1 "):"))
("\\(#!\\)" (1 "<"))
("\\(!\\)" (1 "<"))
("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))))
(defvar factor-mode-syntax-table nil
"Syntax table used while in Factor mode.")
@ -254,11 +261,14 @@ buffer."
;; Whitespace
(modify-syntax-entry ?\t " " factor-mode-syntax-table)
(modify-syntax-entry ?\n ">" factor-mode-syntax-table)
(modify-syntax-entry ?\f " " factor-mode-syntax-table)
(modify-syntax-entry ?\r " " factor-mode-syntax-table)
(modify-syntax-entry ? " " factor-mode-syntax-table)
;; (end of) Comments
(modify-syntax-entry ?\n ">" factor-mode-syntax-table)
;; Parenthesis
(modify-syntax-entry ?\[ "(] " factor-mode-syntax-table)
(modify-syntax-entry ?\] ")[ " factor-mode-syntax-table)
(modify-syntax-entry ?{ "(} " factor-mode-syntax-table)
@ -266,7 +276,10 @@ buffer."
(modify-syntax-entry ?\( "()" factor-mode-syntax-table)
(modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
(modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
;; Strings
(modify-syntax-entry ?\" "\"" factor-mode-syntax-table)
(modify-syntax-entry ?\\ "/" factor-mode-syntax-table)))
;;; Factor mode indentation:
@ -275,10 +288,6 @@ buffer."
(defvar factor-indent-width factor-default-indent-width
"Indentation width in factor buffers. A local variable."))
(defconst factor--regexp-word-start
(let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
(format "^\\(%s\\): " (mapconcat 'identity sws "\\|"))))
(defun factor--guess-indent-width ()
"Chooses an indentation value from existing code."
(let ((word-cont "^ +[^ ]")
@ -494,8 +503,12 @@ buffer."
(setq major-mode 'factor-mode)
(setq mode-name "Factor")
(set (make-local-variable 'comment-start) "! ")
(set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
(set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
(set (make-local-variable 'font-lock-defaults)
'(factor-font-lock-keywords t nil nil nil))
`(factor-font-lock-keywords
nil nil nil nil
(font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
(set-syntax-table factor-mode-syntax-table)
(set (make-local-variable 'indent-line-function) 'factor--indent-line)
(setq factor-indent-width (factor--guess-indent-width))
@ -550,12 +563,15 @@ buffer."
"Keymap for Factor help mode.")
(defconst factor--help-headlines
(regexp-opt '("Parent topics:"
"Inputs and outputs"
"Word description"
(regexp-opt '("Definition"
"Examples"
"Generic word contract"
"Inputs and outputs"
"Parent topics:"
"Syntax"
"Vocabulary"
"Definition")
"Warning"
"Word description")
t))
(defconst factor--help-headlines-regexp (format "^%s" factor--help-headlines))
@ -627,20 +643,24 @@ vocabularies which have been modified on disk."
;;; Key bindings:
(defmacro factor--define-key (key cmd)
`(progn
(define-key factor-mode-map [(control ?c) ,key] ,cmd)
(define-key factor-mode-map [(control ?c) (control ,key)] ,cmd)))
(defmacro factor--define-key (key cmd &optional both)
(let ((m (gensym))
(ms '(factor-mode-map)))
(when both (push 'factor-help-mode-map ms))
`(dolist (,m (list ,@ms))
(define-key ,m [(control ?c) ,key] ,cmd)
(define-key ,m [(control ?c) (control ,key)] ,cmd))))
(factor--define-key ?f 'factor-run-file)
(factor--define-key ?r 'factor-send-region)
(factor--define-key ?d 'factor-send-definition)
(factor--define-key ?s 'factor-see)
(factor--define-key ?s 'factor-see t)
(factor--define-key ?e 'factor-edit)
(factor--define-key ?z 'switch-to-factor)
(factor--define-key ?z 'switch-to-factor t)
(factor--define-key ?c 'comment-region)
(define-key factor-mode-map "\C-ch" 'factor-help)
(define-key factor-help-mode-map "\C-ch" 'factor-help)
(define-key factor-mode-map "\C-m" 'newline-and-indent)
(define-key factor-mode-map [tab] 'indent-for-tab-command)

13
vm/quotations.c
View File

@ -348,8 +348,10 @@ worse than the duplication itself (eg, putting all state in some global
struct.) */
#define COUNT(name,scan) \
{ \
CELL size = array_capacity(code_to_emit(name)) * code_format; \
if(offset == 0) return scan - 1; \
offset -= array_capacity(code_to_emit(name)) * code_format; \
if(offset < size) return scan + 1; \
offset -= size; \
}
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
@ -411,29 +413,28 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
if(stack_frame)
COUNT(userenv[JIT_EPILOG],i)
i += 2;
COUNT(userenv[JIT_IF_JUMP],i)
i += 2;
tail_call = true;
break;
}
else if(jit_fast_dip_p(untag_object(array),i))
{
i++;
COUNT(userenv[JIT_DIP],i)
i++;
break;
}
else if(jit_fast_2dip_p(untag_object(array),i))
{
i++;
COUNT(userenv[JIT_2DIP],i)
i++;
break;
}
else if(jit_fast_3dip_p(untag_object(array),i))
{
i++;
COUNT(userenv[JIT_3DIP],i)
i++;
break;
}
case ARRAY_TYPE: