diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index ef00e94dd5..8c653b866e 100755 --- a/core/compiler/compiler.factor +++ b/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 ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index c2e84429cf..6acd3a6415 100755 --- a/core/compiler/units/units.factor +++ b/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 -- ) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 459512b83a..122205eb26 100755 --- a/core/definitions/definitions.factor +++ b/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 ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index b9a556e316..c99de94ded 100755 --- a/core/generic/generic.factor +++ b/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 diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 51ea4f8225..24fb8ba4f4 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/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? - drop t ; +M: engine-word crossref? drop t ; + +M: engine-word irrelevant? drop t ; : remember-engine ( word -- ) generic get "engines" word-prop push ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 1bff9ae15d..66f191a93f 100644 --- a/core/generic/standard/standard-tests.factor +++ b/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 diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 91314d1312..ccfa490318 100755 --- a/core/inference/backend/backend-docs.factor +++ b/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 diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index c49e7fda8a..42a1c1dd19 100755 --- a/core/inference/backend/backend.factor +++ b/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 - terminated? get over set-effect-terminated? ; + d-in get + meta-d get length + 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 set - [ apply-object terminated? get not ] all? drop - r> recursive-state set ; + recursive-state get [ + recursive-state set + [ apply-object terminated? get not ] all? drop + ] 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 - over value-recursion - rot f 2array prefix infer-quot + [ value-literal ] + [ [ value-recursion ] keep f 2array prefix ] + 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 - over effect-out over produce-values - node, - effect-terminated? [ terminate ] when ; + [ [ in>> ] dip consume-values ] + [ [ out>> ] dip produce-values ] + [ node, 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 - swap [ curried-quot ] map unify-values + [ [ obj>> ] map unify-values ] + [ [ quot>> ] map unify-values ] bi ; : unify-composed ( seq -- value ) - dup [ composed-quot1 ] map unify-values - swap [ composed-quot2 ] map unify-values + [ [ quot1>> ] map unify-values ] + [ [ quot2>> ] map unify-values ] bi ; 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 - over d-in branch-variable - rot meta-d active-variable - unify-effect meta-d set d-in set ; + [ quotation branch-variable ] + [ d-in branch-variable ] + [ meta-d active-variable ] tri + unify-effect + [ d-in set ] [ meta-d set ] bi* ; : retainstack-effect ( seq -- ) - dup quotation branch-variable - over length 0 - rot meta-r active-variable - unify-effect meta-r set drop ; + [ quotation branch-variable ] + [ length 0 ] + [ meta-r active-variable ] tri + unify-effect + [ drop ] [ meta-r set ] bi* ; : unify-effects ( seq -- ) - dup datastack-effect - dup retainstack-effect - [ terminated? swap at ] all? terminated? set ; + [ datastack-effect ] + [ retainstack-effect ] + [ [ 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 - over recorded get push - "inferred-effect" set-word-prop ; + [ check-effect ] + [ drop recorded get push ] + [ "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 - "infer" word-prop call ; + [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ; : 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 + [ word-def ] [ ] 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 node, penultimate-node f over set-node-successor - dup current-node set - ] when drop ; + dup successor>> [ + [ node, ] [ penultimate-node ] bi + f >>successor + current-node set + ] [ drop ] if ; -: apply-infer ( hash -- ) - { meta-d meta-r d-in terminated? } - [ swap [ at ] curry map ] keep - [ set ] 2each ; +: apply-infer ( data -- ) + { meta-d meta-r d-in terminated? } swap extract-keys + namespace swap update ; + +: 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-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? [ - flatten-meta-d >r - drop join-values inline-block apply-infer - r> over set-node-in-d - dup node, - calls>> [ - [ flatten-curries ] modify-values - ] each - ] [ - apply-infer node-child node-successor splice-node drop - ] if ; + dup inline-block over recursive-label? + [ drop inline-recursive-word ] + [ apply-infer node-child successor>> splice-node drop ] if ; M: word apply-object [ diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index f565420cac..3c6680bcde 100644 --- a/core/inference/errors/errors.factor +++ b/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 - over unbalanced-branches-error-in - rot unbalanced-branches-error-out [ length ] map - 3array flip [ [ bl ] [ pprint ] interleave nl ] each ; + [ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 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 . - "Inferred: " write effect-error-effect effect>string . ; + dup word>> stack-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 ; diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index d79c82ed65..acc9329670 100755 --- a/core/inference/inference-docs.factor +++ b/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." diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 0d3eb03cf4..4ce354bdcc 100755 --- a/core/inference/inference-tests.factor +++ b/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 diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 9112dbf25e..61f687c95a 100755 --- a/core/kernel/kernel.factor +++ b/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 -- ) diff --git a/core/words/words.factor b/core/words/words.factor index 5549f98010..bc4b2ede72 100755 --- a/core/words/words.factor +++ b/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 ; - - -: redefined ( word -- ) - H{ } clone visited [ (redefined) ] with-variable ; +M: object redefined drop ; : define ( word def -- ) [ ] like diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index a15a12830c..25bd560d42 100755 --- a/extra/editors/editors.factor +++ b/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 . ] [ diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 10d6070f7b..fc50432030 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -44,8 +44,13 @@ main-responder global [ <404> or ] change-at : do-response ( response -- ) dup write-response - request get method>> "HEAD" = - [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ; + request get method>> "HEAD" = [ drop ] [ + '[ , write-response-body ] + [ + development-mode get + [ http-error. ] [ drop "Response error" ] if + ] recover + ] if ; LOG: httpd-hit NOTICE diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index c4090e1098..14b91aa58b 100644 --- a/extra/lisp/lisp-tests.factor +++ b/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 ] "+" 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 diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index e865a2e3ed..425ee27bb7 100644 --- a/extra/lisp/lisp.factor +++ b/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 ; + +> "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 ; diff --git a/extra/lists/lazy/examples/examples-tests.factor b/extra/lists/lazy/examples/examples-tests.factor index d4e3ed79b8..c088f1d9a7 100644 --- a/extra/lists/lazy/examples/examples-tests.factor +++ b/extra/lists/lazy/examples/examples-tests.factor @@ -1,5 +1,5 @@ -USING: lazy-lists.examples lazy-lists tools.test ; -IN: lazy-lists.examples.tests +USING: lists.lazy.examples lazy-lists tools.test ; +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 diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 6176c12d21..232fdb25b3 100755 --- a/extra/math/functions/functions-tests.factor +++ b/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 diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index bb43e4a721..4dcb215138 100755 --- a/extra/math/functions/functions.factor +++ b/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 diff --git a/extra/math/libm/libm.factor b/extra/math/libm/libm.factor old mode 100644 new mode 100755 index f70c8d2a77..8bda6a6dd0 --- a/extra/math/libm/libm.factor +++ b/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 diff --git a/extra/pango/cairo/samples/samples.factor b/extra/pango/cairo/samples/samples.factor index 644d731d70..f081650943 100644 --- a/extra/pango/cairo/samples/samples.factor +++ b/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 - gadget. ; + gadget. ; : time-pango ( -- ) [ hello-pango ] time ; -! clear the caches, for testing. -: clear-pango ( -- ) - dims get clear-assoc - textures get clear-assoc ; - MAIN: time-pango diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor index f4515a9ebe..3ff22cb0c6 100755 --- a/extra/tools/crossref/crossref.factor +++ b/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 ; diff --git a/extra/tools/profiler/profiler-docs.factor b/extra/tools/profiler/profiler-docs.factor index 50bbc527d1..69edf1a7e0 100755 --- a/extra/tools/profiler/profiler-docs.factor +++ b/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. diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 6a5fce6281..4ae3666829 100755 --- a/extra/tools/profiler/profiler.factor +++ b/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 diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index b18c0c1ad6..695727e314 100755 --- a/extra/ui/tools/search/search.factor +++ b/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 + "" over smart-usage f "Words and methods using " rot word-name append show-titled-popup ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 5e17d02542..d42c679b22 100755 --- a/extra/ui/windows/windows.factor +++ b/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 ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index f9e5667947..125442e17f 100755 --- a/extra/unicode/data/data.factor +++ b/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 ) [ diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml index 38005e6f1c..965f059abd 100644 --- a/extra/webapps/blogs/blogs-common.xml +++ b/extra/webapps/blogs/blogs-common.xml @@ -24,7 +24,7 @@ -

+

diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml index 3489f1e331..23bf513946 100644 --- a/extra/webapps/blogs/view-post.xml +++ b/extra/webapps/blogs/view-post.xml @@ -6,11 +6,11 @@ : - + Recent Posts by - + :