unmaintained: New home for misfit Factor vocabularies.

[factor-unmaintained.git] / specialized / specialized.factor

diff --git a/specialized/specialized.factor b/specialized/specialized.factor
new file mode 100644 (file)
index 0000000..73fe2f6
--- /dev/null
+++ b/specialized/specialized.factor
@@ -0,0 +1,54 @@
+! Copyright (C) 2009, 2010 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel locals accessors compiler.tree.propagation.info
+sequences kernel.private assocs fry parser math quotations
+effects arrays definitions compiler.units namespaces
+compiler.tree.debugger generalizations stack-checker ;
+IN: specialized
+
+: in-compilation-unit? ( -- ? )
+    changed-definitions get >boolean ;
+
+: define-temp-in-unit ( quot effect -- word )
+    in-compilation-unit?
+    [ [ define-temp ] with-nested-compilation-unit ]
+    [ [ define-temp ] with-compilation-unit ]
+    if ;
+
+: final-info-quot ( word -- quot )
+    [ stack-effect in>> length '[ _ ndrop ] ]
+    [ def>> [ final-info ] with-scope >quotation ] bi
+    compose ;
+
+ERROR: bad-outputs word quot ;
+
+: define-outputs ( word quot -- )
+    2dup [ stack-effect ] [ infer ] bi* effect<=
+    [ "outputs" set-word-prop ] [ bad-outputs ] if ;
+
+: record-final-info ( word -- )
+    dup final-info-quot define-outputs ;
+
+:: lookup-specialized ( #call word n -- special-word/f )
+    #call in-d>> n tail* >array [ value-info class>> ] map
+    dup [ object = ] all? [ drop f ] [
+        word "specialized-defs" word-prop [
+            [ declare ] curry word def>> compose
+            word stack-effect define-temp-in-unit
+            dup record-final-info
+            1quotation
+        ] cache
+    ] if ;
+
+: specialized-quot ( word n -- quot )
+    '[ _ _ lookup-specialized ] ;
+
+: make-specialized ( word n -- )
+    [ drop H{ } clone "specialized-defs" set-word-prop ]
+    [ dupd specialized-quot "custom-inlining" set-word-prop ] 2bi ;
+
+SYNTAX: specialized
+    last-word dup stack-effect in>> length make-specialized ;
+
+PREDICATE: specialized-word < word
+   "specialized-defs" word-prop >boolean ;