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

basis/compiler/tests/optimizer.factor

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

basis/sequences/deep/deep-docs.factor

@@ -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 -- ) " } }
+{ $values { "obj" object } { "quot" { $quotation "( elt -- )" } } }
-{ $description "Execute a quotation on each nested element of an object and its children, in preorder." } ;
+{ $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" } }
+{ $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." } ;
+{ $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" } }
+{ $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." } ;
+{ $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" } }
+{ $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 } "." } ;
+{ $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" } }
+{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests whether the given object or any subnode satisfies the given quotation." } ;
+{ $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 )" } }
+{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } }
-{ $description "Modifies each sub-node of an object in place, in preorder." } ;
+{ $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"

basis/sequences/deep/deep.factor

@@ -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
+    over [ pusher [ deep-each ] dip ] dip
-    pusher >r deep-each r>
+    dup branch? [ like ] [ drop ] if ; inline recursive
-    r> 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? [ [
+    over branch? [
-        [ call ] keep over >r deep-change-each r>
+        [ [ call ] keep over [ deep-change-each ] dip ] curry change-each
-    ] curry change-each ] [ 2drop ] if ; inline recursive
+    ] [ 2drop ] if ; inline recursive
 
 : flatten ( obj -- seq )
     [ branch? not ] deep-filter ;

basis/tools/walker/walker-tests.factor

@@ -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 } ] [

basis/tools/walker/walker.factor

@@ -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> [
+    [ clone ] dip [
-        >r clone r>
+        [ clone ] dip
         [
-            >r
+            [
-            [ innermost-frame-scan 1+ ]
+                [ innermost-frame-scan 1+ ]
-            [ innermost-frame-quot ] bi
+                [ innermost-frame-quot ] bi
-            r> call
+            ] 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 = [
+        2dup length = [ nip [ break ] append ] [
-            nip
+            2dup nth \ break = [ nip ] [
-        ] [
+                swap 1+ cut [ break ] swap 3append
-            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 {
+            swap %
-                { [ dup \ break eq? ] [ , ] }
+            [ \ break , ] [
-                { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+                unclip {
-                { [ dup array? ] [ add-breakpoint , \ break , ] }
+                    { [ dup \ break eq? ] [ , ] }
-                { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+                    { [ dup quotation? ] [ add-breakpoint , \ break , ] }
-                [ , \ break , ]
+                    { [ dup array? ] [ add-breakpoint , \ break , ] }
-            } cond %
+                    { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+                    [ , \ break , ]
+                } cond %
+            ] if-empty
         ] [ ] make
     ] change-frame ;
 

core/kernel/kernel-tests.factor

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

extra/mason/test/test.factor

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

extra/wordtimer/wordtimer.factor

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

misc/factor.el

@@ -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-stack-effect)
-    ("!( .* )" . 'factor-font-lock-comment)
-    ("^!.*$" . 'factor-font-lock-comment)
-    (" !.*$" . 'factor-font-lock-comment)
-    ("( .* )" . 'factor-font-lock-stack-effect)
-    ("\"\\(\\\\\"\\|[^\"]\\)*\"" . 'factor-font-lock-string)
     ("\\(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:"
+  (regexp-opt '("Definition"
-                "Inputs and outputs"
+                "Examples"
-                "Word description"
                 "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)
+(defmacro factor--define-key (key cmd &optional both)
-  `(progn
+  (let ((m (gensym))
-     (define-key factor-mode-map [(control ?c) ,key] ,cmd)
+        (ms '(factor-mode-map)))
-     (define-key factor-mode-map [(control ?c) (control ,key)] ,cmd)))
+    (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)
 

vm/quotations.c

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