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

core/compiler/compiler.factor

@@ -35,7 +35,7 @@ IN: compiler
     [ swap save-effect ]
     [ compiled-unxref ]
     [
-        dup compiled-crossref?
+        dup crossref?
         [ dependencies get compiled-xref ] [ drop ] if
     ] tri ;
 

core/compiler/units/units.factor

@@ -66,7 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- )
 
 : compile ( words -- )
     recompile-hook get call
-    dup [ drop compiled-crossref? ] assoc-contains?
+    dup [ drop crossref? ] assoc-contains?
     modify-code-heap ;
 
 SYMBOL: outdated-tuples
@@ -82,7 +82,7 @@ SYMBOL: update-tuples-hook
 : finish-compilation-unit ( -- )
     call-recompile-hook
     call-update-tuples-hook
-    dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
+    dup [ drop crossref? ] assoc-contains? modify-code-heap
      ;
 
 : with-nested-compilation-unit ( quot -- )

core/definitions/definitions.factor

@@ -47,7 +47,17 @@ M: object uses drop f ;
 
 : xref ( defspec -- ) dup uses crossref get add-vertex ;
 
-: usage ( defspec -- seq ) \ f or crossref get at keys ;
+: usage ( defspec -- seq ) crossref get at keys ;
+
+GENERIC: irrelevant? ( defspec -- ? )
+
+M: object irrelevant? drop f ;
+
+GENERIC: smart-usage ( defspec -- seq )
+
+M: f smart-usage drop \ f smart-usage ;
+
+M: object smart-usage usage [ irrelevant? not ] filter ;
 
 : unxref ( defspec -- )
     dup uses crossref get remove-vertex ;

core/generic/generic.factor

@@ -117,6 +117,9 @@ M: method-spec definition
 M: method-spec forget*
     first2 method forget* ;
 
+M: method-spec smart-usage
+    second smart-usage ;
+
 M: method-body definer
     drop \ M: \ ; ;
 
@@ -134,6 +137,9 @@ M: method-body forget*
         [ t "forgotten" set-word-prop ] bi
     ] if ;
 
+M: method-body smart-usage
+    "method-generic" word-prop smart-usage ;
+
 : implementors* ( classes -- words )
     all-words [
         "methods" word-prop keys

core/generic/standard/engines/tuple/tuple.factor

@@ -4,7 +4,7 @@ USING: kernel classes.tuple.private hashtables assocs sorting
 accessors combinators sequences slots.private math.parser words
 effects namespaces generic generic.standard.engines
 classes.algebra math math.private kernel.private
-quotations arrays ;
+quotations arrays definitions ;
 IN: generic.standard.engines.tuple
 
 TUPLE: echelon-dispatch-engine n methods ;
@@ -64,8 +64,9 @@ M: engine-word stack-effect
     [ extra-values ] [ stack-effect ] bi
     dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
 
-M: engine-word compiled-crossref?
+M: engine-word crossref? drop t ;
-    drop t ;
+
+M: engine-word irrelevant? drop t ;
 
 : remember-engine ( word -- )
     generic get "engines" word-prop push ;

core/generic/standard/standard-tests.factor

@@ -3,7 +3,8 @@ USING: tools.test math math.functions math.constants
 generic.standard strings sequences arrays kernel accessors
 words float-arrays byte-arrays bit-arrays parser namespaces
 quotations inference vectors growable hashtables sbufs
-prettyprint byte-vectors bit-vectors float-vectors ;
+prettyprint byte-vectors bit-vectors float-vectors definitions
+generic sets graphs assocs ;
 
 GENERIC: lo-tag-test
 
@@ -287,3 +288,24 @@ M: sbuf no-stack-effect-decl ;
 [ ] [ \ no-stack-effect-decl see ] unit-test
 
 [ ] [ \ no-stack-effect-decl word-def . ] unit-test
+
+! Cross-referencing with generic words
+TUPLE: xref-tuple-1 ;
+TUPLE: xref-tuple-2 < xref-tuple-1 ;
+
+: (xref-test) drop ;
+
+GENERIC: xref-test ( obj -- )
+
+M: xref-tuple-1 xref-test (xref-test) ;
+M: xref-tuple-2 xref-test (xref-test) ;
+
+[ t ] [
+    \ xref-test
+    \ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
+] unit-test
+
+[ t ] [
+    \ xref-test
+    \ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
+] unit-test

core/inference/backend/backend-docs.factor

@@ -61,7 +61,7 @@ HELP: effect-error
 { $description "Throws an " { $link effect-error } "." }
 { $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
 
-HELP: recursive-declare-error
+HELP: no-recursive-declaration
 { $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ;
 
 HELP: recursive-quotation-error

core/inference/backend/backend.factor

@@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
 io.streams.string kernel math namespaces parser prettyprint
 sequences strings vectors words quotations effects classes
 continuations debugger assocs combinators compiler.errors
-generic.standard.engines.tuple accessors math.order ;
+generic.standard.engines.tuple accessors math.order definitions ;
 IN: inference.backend
 
 : recursive-label ( word -- label/f )
@@ -21,6 +21,28 @@ M: engine-word inline?
 M: word inline?
     "inline" word-prop ;
 
+SYMBOL: visited
+
+: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
+
+: (redefined) ( word -- )
+    dup visited get key? [ drop ] [
+        [ reset-on-redefine reset-props ]
+        [ dup visited get set-at ]
+        [
+            crossref get at keys
+            [ word? ] filter
+            [
+                [ reset-on-redefine [ word-prop ] with contains? ]
+                [ inline? ]
+                bi or
+            ] filter
+            [ (redefined) ] each
+        ] tri
+    ] if ;
+
+M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
+
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys
     [ dup word? [ inline? ] when not ] find drop
@@ -68,8 +90,9 @@ M: object value-literal \ literal-expected inference-warning ;
     meta-d [ add-inputs ] change d-in [ + ] change ;
 
 : current-effect ( -- effect )
-    d-in get meta-d get length <effect>
+    d-in get
-    terminated? get over set-effect-terminated? ;
+    meta-d get length <effect>
+    terminated? get >>terminated? ;
 
 : init-inference ( -- )
     terminated? off
@@ -93,13 +116,13 @@ M: wrapper apply-object
     terminated? on #terminate node, ;
 
 : infer-quot ( quot rstate -- )
-    recursive-state get >r
+    recursive-state get [
-    recursive-state set
+        recursive-state set
-    [ apply-object terminated? get not ] all? drop
+        [ apply-object terminated? get not ] all? drop
-    r> recursive-state set ;
+    ] dip recursive-state set ;
 
 : infer-quot-recursive ( quot word label -- )
-    recursive-state get -rot 2array prefix infer-quot ;
+    2array recursive-state get swap prefix infer-quot ;
 
 : time-bomb ( error -- )
     [ throw ] curry recursive-state get infer-quot ;
@@ -114,9 +137,9 @@ TUPLE: recursive-quotation-error quot ;
         value-literal recursive-quotation-error inference-error
     ] [
         dup value-literal callable? [
-            dup value-literal
+            [ value-literal ]
-            over value-recursion
+            [ [ value-recursion ] keep f 2array prefix ]
-            rot f 2array prefix infer-quot
+            bi infer-quot
         ] [
             drop bad-call
         ] if
@@ -169,26 +192,26 @@ TUPLE: too-many-r> ;
     meta-d get push-all ;
 
 : if-inline ( word true false -- )
-    >r >r dup inline? r> r> if ; inline
+    [ dup inline? ] 2dip if ; inline
 
 : consume/produce ( effect node -- )
-    over effect-in over consume-values
+    [ [ in>> ] dip consume-values ]
-    over effect-out over produce-values
+    [ [ out>> ] dip produce-values ]
-    node,
+    [ node, terminated?>> [ terminate ] when ]
-    effect-terminated? [ terminate ] when ;
+    2tri ;
 
 GENERIC: constructor ( value -- word/f )
 
 GENERIC: infer-uncurry ( value -- )
 
 M: curried infer-uncurry
-    drop pop-d dup curried-obj push-d curried-quot push-d ;
+    drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ;
 
 M: curried constructor
     drop \ curry ;
 
 M: composed infer-uncurry
-    drop pop-d dup composed-quot1 push-d composed-quot2 push-d ;
+    drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ;
 
 M: composed constructor
     drop \ compose ;
@@ -233,13 +256,13 @@ M: object constructor drop f ;
 DEFER: unify-values
 
 : unify-curries ( seq -- value )
-    dup [ curried-obj ] map unify-values
+    [ [ obj>> ] map unify-values ]
-    swap [ curried-quot ] map unify-values
+    [ [ quot>> ] map unify-values ] bi
     <curried> ;
 
 : unify-composed ( seq -- value )
-    dup [ composed-quot1 ] map unify-values
+    [ [ quot1>> ] map unify-values ]
-    swap [ composed-quot2 ] map unify-values
+    [ [ quot2>> ] map unify-values ] bi
     <composed> ;
 
 TUPLE: cannot-unify-specials ;
@@ -270,7 +293,7 @@ TUPLE: unbalanced-branches-error quots in out ;
 
 : unify-inputs ( max-d-in d-in meta-d -- meta-d )
     dup [
-        [ >r - r> length + ] keep add-inputs nip
+        [ [ - ] dip length + ] keep add-inputs nip
     ] [
         2nip
     ] if ;
@@ -296,21 +319,24 @@ TUPLE: unbalanced-branches-error quots in out ;
     [ swap at ] curry map ;
 
 : datastack-effect ( seq -- )
-    dup quotation branch-variable
+    [ quotation branch-variable ]
-    over d-in branch-variable
+    [ d-in branch-variable ]
-    rot meta-d active-variable
+    [ meta-d active-variable ] tri
-    unify-effect meta-d set d-in set ;
+    unify-effect
+    [ d-in set ] [ meta-d set ] bi* ;
 
 : retainstack-effect ( seq -- )
-    dup quotation branch-variable
+    [ quotation branch-variable ]
-    over length 0 <repetition>
+    [ length 0 <repetition> ]
-    rot meta-r active-variable
+    [ meta-r active-variable ] tri
-    unify-effect meta-r set drop ;
+    unify-effect
+    [ drop ] [ meta-r set ] bi* ;
 
 : unify-effects ( seq -- )
-    dup datastack-effect
+    [ datastack-effect ]
-    dup retainstack-effect
+    [ retainstack-effect ]
-    [ terminated? swap at ] all? terminated? set ;
+    [ [ terminated? swap at ] all? terminated? set ]
+    tri ;
 
 : unify-dataflow ( effects -- nodes )
     dataflow-graph branch-variable ;
@@ -325,14 +351,17 @@ TUPLE: unbalanced-branches-error quots in out ;
 : infer-branch ( last value -- namespace )
     [
         copy-inference
-        dup value-literal quotation set
+
-        infer-quot-value
+        [ value-literal quotation set ]
+        [ infer-quot-value ]
+        bi
+
         terminated? get [ drop ] [ call node, ] if
     ] H{ } make-assoc ; inline
 
 : (infer-branches) ( last branches -- list )
     [ infer-branch ] with map
-    dup unify-effects unify-dataflow ; inline
+    [ unify-effects ] [ unify-dataflow ] bi ; inline
 
 : infer-branches ( last branches node -- )
     #! last is a quotation which provides a #return or a #values
@@ -368,9 +397,10 @@ TUPLE: effect-error word effect ;
 
 : finish-word ( word -- )
     current-effect
-    2dup check-effect
+    [ check-effect ]
-    over recorded get push
+    [ drop recorded get push ]
-    "inferred-effect" set-word-prop ;
+    [ "inferred-effect" set-word-prop ]
+    2tri ;
 
 : infer-word ( word -- effect )
     [
@@ -386,8 +416,7 @@ TUPLE: effect-error word effect ;
 
 : custom-infer ( word -- )
     #! Customized inference behavior
-    dup +inlined+ depends-on
+    [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
-    "infer" word-prop call ;
 
 : cached-infer ( word -- )
     dup "inferred-effect" word-prop make-call-node ;
@@ -400,13 +429,13 @@ TUPLE: effect-error word effect ;
         [ dup infer-word make-call-node ]
     } cond ;
 
-TUPLE: recursive-declare-error word ;
+TUPLE: no-recursive-declaration word ;
 
 : declared-infer ( word -- )
     dup stack-effect [
         make-call-node
     ] [
-        \ recursive-declare-error inference-error
+        \ no-recursive-declaration inference-error
     ] if* ;
 
 GENERIC: collect-label-info* ( label node -- )
@@ -441,40 +470,56 @@ M: #return collect-label-info*
 : inline-block ( word -- #label data )
     [
         copy-inference nest-node
-        dup word-def swap <inlined-block>
+        [ word-def ] [ <inlined-block> ] bi
         [ infer-quot-recursive ] 2keep
         #label unnest-node
         dup collect-label-info
     ] H{ } make-assoc ;
 
 : join-values ( #label -- )
-    calls>> [ node-in-d ] map meta-d get suffix
+    calls>> [ in-d>> ] map meta-d get suffix
     unify-lengths unify-stacks
     meta-d [ length tail* ] change ;
 
 : splice-node ( node -- )
-    dup node-successor [
+    dup successor>> [
-        dup node, penultimate-node f over set-node-successor
+        [ node, ] [ penultimate-node ] bi
-        dup current-node set
+        f >>successor
-    ] when drop ;
+        current-node set
+    ] [ drop ] if ;
 
-: apply-infer ( hash -- )
+: apply-infer ( data -- )
-    { meta-d meta-r d-in terminated? }
+    { meta-d meta-r d-in terminated? } swap extract-keys
-    [ swap [ at ] curry map ] keep
+    namespace swap update ;
-    [ set ] 2each ;
+
+: current-stack-height ( -- n )
+    meta-d get length d-in get - ;
+
+: word-stack-height ( word -- n )
+    stack-effect [ in>> length ] [ out>> length ] bi - ;
+
+: bad-recursive-declaration ( word inferred -- )
+    dup 0 < [ 0 ] [ 0 swap ] if <effect> effect-error ;
+
+: check-stack-height ( word height -- )
+    over word-stack-height over =
+    [ 2drop ] [ bad-recursive-declaration ] if ;
+
+: inline-recursive-word ( word #label -- )
+    current-stack-height [
+        flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d
+        [ node, ]
+        [ calls>> [ [ flatten-curries ] modify-values ] each ]
+        [ word>> ]
+        tri
+    ] dip
+    current-stack-height -
+    check-stack-height ;
 
 : inline-word ( word -- )
-    dup inline-block over recursive-label? [
+    dup inline-block over recursive-label?
-        flatten-meta-d >r
+    [ drop inline-recursive-word ]
-        drop join-values inline-block apply-infer
+    [ apply-infer node-child successor>> splice-node drop ] if ;
-        r> over set-node-in-d
-        dup node,
-        calls>> [
-            [ flatten-curries ] modify-values
-        ] each
-    ] [
-        apply-infer node-child node-successor splice-node drop
-    ] if ;
 
 M: word apply-object
     [

core/inference/errors/errors.factor

@@ -15,10 +15,8 @@ M: inference-error error-help drop f ;
 
 M: unbalanced-branches-error error.
     "Unbalanced branches:" print
-    dup unbalanced-branches-error-quots
+    [ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip
-    over unbalanced-branches-error-in
+    [ [ bl ] [ pprint ] interleave nl ] each ;
-    rot unbalanced-branches-error-out [ length ] map
-    3array flip [ [ bl ] [ pprint ] interleave nl ] each ;
 
 M: literal-expected summary
     drop "Literal value expected" ;
@@ -32,24 +30,24 @@ M: too-many-r> summary
     "Quotation pops retain stack elements which it did not push" ;
 
 M: no-effect error.
-    "Unable to infer stack effect of " write no-effect-word . ;
+    "Unable to infer stack effect of " write word>> . ;
 
-M: recursive-declare-error error.
+M: no-recursive-declaration error.
     "The recursive word " write
-    recursive-declare-error-word pprint
+    word>> pprint
     " must declare a stack effect" print ;
 
 M: effect-error error.
     "Stack effects of the word " write
-    dup effect-error-word pprint
+    dup word>> pprint
     " do not match." print
     "Declared: " write
-    dup effect-error-word stack-effect effect>string .
+    dup word>> stack-effect effect>string .
-    "Inferred: " write effect-error-effect effect>string . ;
+    "Inferred: " write effect>> effect>string . ;
 
 M: recursive-quotation-error error.
     "The quotation " write
-    recursive-quotation-error-quot pprint
+    quot>> pprint
     " calls itself." print
     "Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
 

core/inference/inference-docs.factor

@@ -89,7 +89,7 @@ ARTICLE: "inference-errors" "Inference errors"
 { $subsection too-many-r> }
 { $subsection unbalanced-branches-error }
 { $subsection effect-error }
-{ $subsection recursive-declare-error } ;
+{ $subsection no-recursive-declaration } ;
 
 ARTICLE: "inference" "Stack effect inference"
 "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."

core/inference/inference-tests.factor

@@ -549,10 +549,34 @@ ERROR: custom-error ;
 { 1 0 } [ [ ] map-children ] must-infer-as
 
 ! Corner case
-! [ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
+[ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
 
-! [ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
+[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
 
-! : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
+: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
 
-! [ [ erg's-inference-bug ] infer ] must-fail
+[ [ erg's-inference-bug ] infer ] must-fail
+
+: inference-invalidation-a ;
+: inference-invalidation-b [ inference-invalidation-a ] dip call ; inline
+: inference-invalidation-c [ + ] inference-invalidation-b ;
+
+[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
+
+{ 2 1 } [ inference-invalidation-c ] must-infer-as
+
+[ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
+
+[ 3 ] [ inference-invalidation-c ] unit-test
+
+{ 0 1 } [ inference-invalidation-c ] must-infer-as
+
+GENERIC: inference-invalidation-d ( obj -- )
+
+M: object inference-invalidation-d inference-invalidation-c 2drop ;
+
+\ inference-invalidation-d must-infer
+
+[ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
+
+[ [ inference-invalidation-d ] infer ] must-fail

core/kernel/kernel.factor

@@ -72,7 +72,7 @@ DEFER: if
     >r keep r> call ; inline
 
 : tri ( x p q r -- )
-    >r pick >r bi r> r> call ; inline
+    >r >r keep r> keep r> call ; inline
 
 ! Double cleavers
 : 2bi ( x y p q -- )
@@ -93,7 +93,7 @@ DEFER: if
     >r dip r> call ; inline
 
 : tri* ( x y z p q r -- )
-    >r rot >r bi* r> r> call ; inline
+    >r >r 2dip r> dip r> call ; inline
 
 ! Double spreaders
 : 2bi* ( w x y z p q -- )

core/words/words.factor

@@ -102,7 +102,7 @@ SYMBOL: compiled-crossref
 compiled-crossref global [ H{ } assoc-like ] change-at
 
 : compiled-xref ( word dependencies -- )
-    [ drop compiled-crossref? ] assoc-filter
+    [ drop crossref? ] assoc-filter
     2dup "compiled-uses" set-word-prop
     compiled-crossref get add-vertex* ;
 
@@ -125,28 +125,9 @@ SYMBOL: +called+
         compiled-usage [ nip +inlined+ eq? ] assoc-filter update
     ] with each keys ;
 
-<PRIVATE
+GENERIC: redefined ( word -- )
 
-SYMBOL: visited
+M: object redefined drop ;
-
-: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
-
-: (redefined) ( word -- )
-    dup visited get key? [ drop ] [
-        [ reset-on-redefine reset-props ]
-        [ dup visited get set-at ]
-        [
-            crossref get at keys
-            [ word? ] filter
-            [ reset-on-redefine [ word-prop ] with contains? ] filter
-            [ (redefined) ] each
-        ] tri
-    ] if ;
-
-PRIVATE>
-
-: redefined ( word -- )
-    H{ } clone visited [ (redefined) ] with-variable ;
 
 : define ( word def -- )
     [ ] like

extra/editors/editors.factor

@@ -53,7 +53,7 @@ M: object find-parse-error
 
 : fix ( word -- )
     [ "Fixing " write pprint " and all usages..." print nl ]
-    [ [ usage ] keep prefix ] bi
+    [ [ smart-usage ] keep prefix ] bi
     [
         [ "Editing " write . ]
         [

extra/http/server/server.factor

@@ -44,8 +44,13 @@ main-responder global [ <404> <trivial-responder> or ] change-at
 
 : do-response ( response -- )
     dup write-response
-    request get method>> "HEAD" =
+    request get method>> "HEAD" = [ drop ] [
-    [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ;
+        '[ , write-response-body ]
+        [
+            development-mode get
+            [ http-error. ] [ drop "Response error" ] if
+        ] recover
+    ] if ;
 
 LOG: httpd-hit NOTICE
 

extra/lisp/lisp-tests.factor

@@ -13,8 +13,6 @@ IN: lisp.test
     "+" "math" "+" define-primitive
     "-" "math" "-" define-primitive
     
-!    "list" [ >array ] lisp-define
-    
     { 5 } [
       [ 2 3 ] "+" <lisp-symbol> funcall
     ] unit-test
@@ -55,8 +53,4 @@ IN: lisp.test
        "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
     ] unit-test
     
-!     { { 1 2 3 4 5 } } [
-!       "(list 1 2 3 4 5)" lisp-eval
-!     ] unit-test
-
 ] with-interactive-vocabs

extra/lisp/lisp.factor

@@ -59,10 +59,23 @@ PRIVATE>
 : convert-unquoted ( cons -- quot )    
     "unquote not valid outside of quasiquote!" throw ;
     
-: convert-quasiquoted ( cons -- newcons )
+: convert-unquoted-splicing ( cons -- quot )    
+    "unquote-splicing not valid outside of quasiquote!" throw ;
+    
+<PRIVATE    
+: quasiquote-unquote ( cons -- newcons )
     [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
     [ cadr ] traverse ;
     
+: quasiquote-unquote-splicing ( cons -- newcons )    
+    [ { [ dup list? ] [ dup cdr [ cons? ] [ car cons? ] bi and ]
+        [ dup cadr car lisp-symbol? ] [ cadr car name>> "unquote-splicing" equal? dup ] } && nip ]
+    [ dup cadr cdr >>cdr ] traverse ;
+PRIVATE>
+
+: convert-quasiquoted ( cons -- newcons )
+    quasiquote-unquote quasiquote-unquote-splicing ;
+    
 : convert-defmacro ( cons -- quot )
     cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
     
@@ -72,6 +85,7 @@ PRIVATE>
       { "defmacro" [ convert-defmacro ] }
       { "quote" [ convert-quoted ] }
       { "unquote" [ convert-unquoted ] }
+      { "unquote-splicing" [ convert-unquoted-splicing ] }
       { "quasiquote" [ convert-quasiquoted ] }
       { "begin" [ convert-begin ] }
       { "cond" [ convert-cond ] }
@@ -99,7 +113,7 @@ PRIVATE>
     call ; inline
     
 : macro-expand ( cons -- quot )
-    uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form  ] bi* call ;
+    uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form  ] bi* ;
     
 : lisp-string>factor ( str -- quot )
     lisp-expr parse-result-ast compile-form ;

extra/lists/lazy/examples/examples-tests.factor

@@ -1,5 +1,5 @@
-USING: lazy-lists.examples lazy-lists tools.test ;
+USING: lists.lazy.examples lazy-lists tools.test ;
-IN: lazy-lists.examples.tests
+IN: lists.lazy.examples.tests
 
 [ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
 [ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test

extra/math/functions/functions-tests.factor

@@ -44,7 +44,10 @@ IN: math.functions.tests
 
 [ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
 [ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
+[ t ] [ -100 atan tan -100 1.e-10 ~ ] unit-test
 [ t ] [ 10 asinh sinh 10 1.e-10 ~ ] unit-test
+[ t ] [ 10 atanh tanh 10 1.e-10 ~ ] unit-test
+[ t ] [ 0.5 atanh tanh 0.5 1.e-10 ~ ] unit-test
 
 [ 100 ] [ 100 100 gcd nip ] unit-test
 [ 100 ] [ 1000 100 gcd nip ] unit-test

extra/math/functions/functions.factor

@@ -182,17 +182,17 @@ M: number (^)
 : coth ( x -- y ) tanh recip ; inline
 
 : acosh ( x -- y )
-    dup >=1? [ facosh ] [ dup sq 1- sqrt + log ] if ; inline
+    dup sq 1- sqrt + log ; inline
 
 : asech ( x -- y ) recip acosh ; inline
 
 : asinh ( x -- y )
-    dup complex? [ dup sq 1+ sqrt + log ] [ fasinh ] if ; inline
+    dup sq 1+ sqrt + log ; inline
 
 : acosech ( x -- y ) recip asinh ; inline
 
 : atanh ( x -- y )
-    dup [-1,1]? [ fatanh ] [ dup 1+ swap 1- neg / log 2 / ] if ; inline
+    dup 1+ swap 1- neg / log 2 / ; inline
 
 : acoth ( x -- y ) recip atanh ; inline
 

extra/math/libm/libm.factor

@@ -15,18 +15,6 @@ IN: math.libm
     "double" "libm" "atan" { "double" } alien-invoke ;
     foldable
 
-: facosh ( x -- y )
-    "double" "libm" "acosh" { "double" } alien-invoke ;
-    foldable
-
-: fasinh ( x -- y )
-    "double" "libm" "asinh" { "double" } alien-invoke ;
-    foldable
-
-: fatanh ( x -- y )
-    "double" "libm" "atanh" { "double" } alien-invoke ;
-    foldable
-
 : fatan2 ( x y -- z )
     "double" "libm" "atan2" { "double" "double" } alien-invoke ;
     foldable
@@ -70,3 +58,16 @@ IN: math.libm
 : fsqrt ( x -- y )
     "double" "libm" "sqrt" { "double" } alien-invoke ;
     foldable
+    
+! Windows doesn't have these...
+: facosh ( x -- y )
+    "double" "libm" "acosh" { "double" } alien-invoke ;
+    foldable
+
+: fasinh ( x -- y )
+    "double" "libm" "asinh" { "double" } alien-invoke ;
+    foldable
+
+: fatanh ( x -- y )
+    "double" "libm" "atanh" { "double" } alien-invoke ;
+    foldable

extra/pango/cairo/samples/samples.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: prettyprint sequences ui.gadgets.panes
 pango.cairo.gadgets math kernel cairo cairo.ffi
-pango.cairo tools.time namespaces assocs
+pango.cairo pango.gadgets tools.time namespaces assocs
 threads io.backend io.encodings.utf8 io.files ;
 
 IN: pango.cairo.samples
@@ -10,14 +10,9 @@ IN: pango.cairo.samples
 : hello-pango ( -- )
     "monospace 10" "resource:extra/pango/cairo/gadgets/gadgets.factor"
     normalize-path utf8 file-contents
-    <pango-gadget> gadget. ;
+    <pango> gadget. ;
 
 : time-pango ( -- )
     [ hello-pango ] time ;
 
-! clear the caches, for testing.
-: clear-pango ( -- )
-    dims get clear-assoc
-    textures get clear-assoc ;
-
 MAIN: time-pango

extra/tools/crossref/crossref.factor

@@ -7,7 +7,7 @@ sorting hashtables vocabs parser source-files ;
 IN: tools.crossref
 
 : usage. ( word -- )
-    usage sorted-definitions. ;
+    smart-usage sorted-definitions. ;
 
 : words-matching ( str -- seq )
     all-words [ dup word-name ] { } map>assoc completions ;

extra/tools/profiler/profiler-docs.factor

@@ -44,7 +44,7 @@ HELP: vocab-profile.
 HELP: usage-profile.
 { $values { "word" word } }
 { $description "Prints a table of call counts from the most recent invocation of " { $link profile } ", for words which directly call " { $snippet "word" } " only." }
-{ $notes "This word obtains the list of static usages with the " { $link usage } " word, and is not aware of dynamic call history. Consider the following scenario. A word " { $snippet "X" } " can execute word " { $snippet "Y" } " in a conditional branch, and " { $snippet "X" } " is executed many times during the profiling run, but this particular branch executing " { $snippet "Y" } " is never taken. However, some other word does execute " { $snippet "Y" } " multiple times. Then " { $snippet "\\ Y usage-profile." } " will list a number of calls to " { $snippet "X" } ", even though " { $snippet "Y" } " was never executed " { $emphasis "from" } " " { $snippet "X" } "." }
+{ $notes "This word obtains the list of static usages with the " { $link smart-usage } " word, and is not aware of dynamic call history. Consider the following scenario. A word " { $snippet "X" } " can execute word " { $snippet "Y" } " in a conditional branch, and " { $snippet "X" } " is executed many times during the profiling run, but this particular branch executing " { $snippet "Y" } " is never taken. However, some other word does execute " { $snippet "Y" } " multiple times. Then " { $snippet "\\ Y usage-profile." } " will list a number of calls to " { $snippet "X" } ", even though " { $snippet "Y" } " was never executed " { $emphasis "from" } " " { $snippet "X" } "." }
 { $examples { $code "\\ + usage-profile." } } ;
 
 HELP: vocabs-profile.

extra/tools/profiler/profiler.factor

@@ -58,7 +58,7 @@ M: method-body (profile.)
     "Call counts for words which call " write
     dup pprint
     ":" print
-    usage [ word? ] filter counters counters. ;
+    smart-usage [ word? ] filter counters counters. ;
 
 : vocabs-profile. ( -- )
     "Call counts for all vocabularies:" print

extra/ui/tools/search/search.factor

@@ -94,7 +94,7 @@ M: live-search pref-dim* drop { 400 200 } ;
     "Words in " rot vocab-name append show-titled-popup ;
 
 : show-word-usage ( workspace word -- )
-    "" over usage f <definition-search>
+    "" over smart-usage f <definition-search>
     "Words and methods using " rot word-name append
     show-titled-popup ;
 

extra/ui/windows/windows.factor

@@ -3,7 +3,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings arrays assocs ui
 ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
-ui.gestures io kernel math math.vectors namespaces prettyprint
+ui.gestures io kernel math math.vectors namespaces
 sequences strings vectors words windows.kernel32 windows.gdi32
 windows.user32 windows.opengl32 windows.messages windows.types
 windows.nt windows threads libc combinators continuations
@@ -380,7 +380,7 @@ SYMBOL: trace-messages?
     "uint" { "void*" "uint" "long" "long" } "stdcall" [
         [
             pick
-            trace-messages? get-global [ dup windows-message-name . ] when
+            trace-messages? get-global [ dup windows-message-name word-name print flush ] when
             wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
         ] ui-try
      ] alien-callback ;

extra/unicode/data/data.factor

@@ -46,11 +46,11 @@ VALUE: properties
 
 : (process-data) ( index data -- newdata )
     filter-comments
-    [ [ nth ] keep first swap 2array ] with map
+    [ [ nth ] keep first swap ] with { } map>assoc
     [ >r hex> r> ] assoc-map ;
 
 : process-data ( index data -- hash )
-    (process-data) [ hex> ] assoc-map >hashtable ;
+    (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ;
 
 : (chain-decomposed) ( hash value -- newvalue )
     [

extra/webapps/blogs/blogs-common.xml

@@ -24,7 +24,7 @@
 
 	</div>
 
-	<h2><t:write-title /></h2>
+	<h1><t:write-title /></h1>
 
 	<t:call-next-template />
 

extra/webapps/blogs/view-post.xml

@@ -6,11 +6,11 @@
 		<t:label t:name="author" />: <t:label t:name="title" />
 	</t:atom>
 
-	<t:atom t:href="$blogs/by" t:query="author">
+	<t:atom t:href="$blogs/by.atom" t:query="author">
 		Recent Posts by <t:label t:name="author" />
 	</t:atom>
 
-	<t:title> <t:label t:name="title" /> </t:title>
+	<t:title> <t:label t:name="author" />: <t:label t:name="title" /> </t:title>
 
 	<p class="posting-body">
 		<t:farkup t:name="content" />