macros: macro body is now defined in its own subword, for compile-time stack effect checking

basis/cocoa/cocoa.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2006, 2009 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler io kernel cocoa.runtime cocoa.subclassing
 cocoa.messages cocoa.types sequences words vocabs parser
 core-foundation.bundles namespaces assocs hashtables
-compiler.units lexer init ;
+compiler.units lexer init macros quotations fry alien.c-types
+arrays combinators ;
 IN: cocoa
 
 : (remember-send) ( selector variable -- )
@@ -14,7 +15,7 @@ SYMBOL: sent-messages
 : remember-send ( selector -- )
     sent-messages (remember-send) ;
 
-SYNTAX: -> scan dup remember-send suffix! \ send suffix! ;
+SYNTAX: -> scan [ remember-send ] [ suffix! ] bi \ send suffix! ;
 
 SYMBOL: super-sent-messages
 
@@ -33,6 +34,14 @@ SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
 
 SYNTAX: IMPORT: scan [ ] import-objc-class ;
 
+MACRO: objc-class-case ( alist -- quot )
+    "isKindOfClass:" remember-send
+    [
+        dup callable?
+        [ first2 [ '[ dup _ execute "isKindOfClass:" send c-bool> ] ] dip 2array ]
+        unless
+    ] map '[ _ cond ] ;
+
 "Importing Cocoa classes..." print
 
 "cocoa.classes" create-vocab drop

basis/cocoa/plists/plists.factor

@@ -40,13 +40,6 @@ DEFER: plist>
     [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
     *void* [ -> release "read-plist failed" throw ] when* ;
 
-MACRO: objc-class-case ( alist -- quot )
-    [
-        dup callable?
-        [ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
-        unless
-    ] map '[ _ cond ] ;
-
 PRIVATE>
 
 ERROR: invalid-plist-object object ;

basis/compiler/tree/debugger/debugger.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs match fry accessors namespaces make effects
-sequences sequences.private quotations generic macros arrays
+sequences sequences.private quotations generic arrays
 prettyprint prettyprint.backend prettyprint.custom
 prettyprint.sections math words combinators
 combinators.short-circuit io sorting hints
@@ -30,34 +30,31 @@ IN: compiler.tree.debugger
 
 GENERIC: node>quot ( node -- )
 
-MACRO: match-choose ( alist -- )
-    [ '[ _ ] ] assoc-map '[ _ match-cond ] ;
-
 MATCH-VARS: ?a ?b ?c ;
 
 : pretty-shuffle ( effect -- word/f )
     [ in>> ] [ out>> ] bi 2array {
-        { { { } { } } [ ] }
-        { { { ?a } { ?a } } [ ] }
-        { { { ?a ?b } { ?a ?b } } [ ] }
-        { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
-        { { { ?a } { } } [ drop ] }
-        { { { ?a ?b } { } } [ 2drop ] }
-        { { { ?a ?b ?c } { } } [ 3drop ] }
-        { { { ?a } { ?a ?a } } [ dup ] }
-        { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
-        { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
-        { { { ?a ?b } { ?a ?b ?a } } [ over ] }
-        { { { ?b ?a } { ?a ?b } } [ swap ] }
-        { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
-        { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
-        { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
-        { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
-        { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
-        { { { ?a ?b } { ?b } } [ nip ] }
-        { { { ?a ?b ?c } { ?c } } [ 2nip ] }
-        { __ f }
-    } match-choose ;
+        { { { } { } } [ [ ] ] }
+        { { { ?a } { ?a } } [ [ ] ] }
+        { { { ?a ?b } { ?a ?b } } [ [ ] ] }
+        { { { ?a ?b ?c } { ?a ?b ?c } } [ [ ] ] }
+        { { { ?a } { } } [ [ drop ] ] }
+        { { { ?a ?b } { } } [ [ 2drop ] ] }
+        { { { ?a ?b ?c } { } } [ [ 3drop ] ] }
+        { { { ?a } { ?a ?a } } [ [ dup ] ] }
+        { { { ?a ?b } { ?a ?b ?a ?b } } [ [ 2dup ] ] }
+        { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ [ 3dup ] ] }
+        { { { ?a ?b } { ?a ?b ?a } } [ [ over ] ] }
+        { { { ?b ?a } { ?a ?b } } [ [ swap ] ] }
+        { { { ?b ?a ?c } { ?a ?b ?c } } [ [ swapd ] ] }
+        { { { ?a ?b } { ?a ?a ?b } } [ [ dupd ] ] }
+        { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ [ pick ] ] }
+        { { { ?a ?b ?c } { ?c ?a ?b } } [ [ -rot ] ] }
+        { { { ?a ?b ?c } { ?b ?c ?a } } [ [ rot ] ] }
+        { { { ?a ?b } { ?b } } [ [ nip ] ] }
+        { { { ?a ?b ?c } { ?c } } [ [ 2nip ] ] }
+        { __ [ f ] }
+    } match-cond ;
 
 TUPLE: shuffle-node { effect effect } ;
 

basis/macros/expander/expander.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private namespaces make
 quotations accessors words continuations vectors effects math
-generalizations fry arrays ;
+generalizations fry arrays combinators ;
 IN: macros.expander
 
 GENERIC: expand-macros ( quot -- quot' )
@@ -55,7 +55,7 @@ M: wrapper expand-macros* wrapped>> literal ;
 
 : word, ( word -- ) end , ;
 
-: expand-macro ( word quot -- )
+: expand-transform ( word quot -- )
     '[
         drop
         stack [ _ with-datastack >vector ] change
@@ -65,18 +65,25 @@ M: wrapper expand-macros* wrapped>> literal ;
         word,
     ] recover ;
 
-: expand-macro? ( word -- quot ? )
-    dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
-        swap [ "transform-n" word-prop ] [ stack-effect in>> length ] bi or
+: expand-transform? ( word -- ? )
+    dup "transform-quot" word-prop [
+        "transform-n" word-prop
         stack get length <=
-    ] [ 2drop f f ] if ;
+    ] [ drop f ] if ;
+
+: expand-macro? ( word -- ? )
+    dup "macro" word-prop [
+        stack-effect in>> length
+        stack get length <=
+    ] [ drop f ] if ;
 
 M: word expand-macros*
-    dup expand-dispatch? [ drop expand-dispatch ] [
-        dup expand-macro? [ expand-macro ] [
-            drop word,
-        ] if
-    ] if ;
+    {
+        { [ dup expand-dispatch? ] [ drop expand-dispatch ] }
+        { [ dup expand-macro? ] [ dup "macro" word-prop '[ _ execute ] expand-transform ] }
+        { [ dup expand-transform? ] [ dup "transform-quot" word-prop expand-transform ] }
+        [ word, ]
+    } cond ;
 
 M: object expand-macros* literal ;
 

basis/macros/macros-docs.factor

@@ -47,9 +47,7 @@ $nl
 $nl
 "Defining new macros:"
 { $subsections POSTPONE: MACRO: }
-"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion."
-{ $subsections define-transform }
-"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated."
+"As with parsing words, macros cannot be used from the same source file that they are defined in."
 { $see-also "generalizations" "fry" } ;
 
 ABOUT: "macros"

basis/macros/macros-tests.factor

@@ -1,6 +1,7 @@
-IN: macros.tests
 USING: tools.test macros math kernel arrays
-vectors io.streams.string prettyprint parser eval see ;
+vectors io.streams.string prettyprint parser eval see
+stack-checker compiler.units definitions vocabs ;
+IN: macros.tests
 
 MACRO: see-test ( a b -- quot ) + ;
 
@@ -19,7 +20,18 @@ unit-test
 
 [ f ] [ \ see-test macro? ] unit-test
 
-[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
+[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ;" eval( -- ) ] unit-test
+[ ] [ "USING: macros kernel ; IN: hanging-macro : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
+
+[ ] [ [ "hanging-macro" forget-vocab ] with-compilation-unit ] unit-test
 
 [ ] [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ;" eval( -- ) ] unit-test
     [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ; inline" eval( -- ) ] must-fail
+
+! The macro expander code should infer
+MACRO: bad-macro ( a -- b ) 1 2 3 [ ] ;
+
+[ [ 0 bad-macro ] call ] must-fail
+[ [ 0 bad-macro ] infer ] must-fail
+
+[ ] [ [ \ bad-macro forget ] with-compilation-unit ] unit-test

basis/macros/macros.factor

@@ -1,23 +1,47 @@
 ! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser kernel sequences words effects combinators assocs
-definitions quotations namespaces memoize accessors
+definitions quotations namespaces memoize accessors arrays
 compiler.units ;
 IN: macros
 
 <PRIVATE
 
+! The macro expander is split off into its own word. This allows
+! the optimizing compiler to optimize and check the stack effect
+! of the expander, even though the actual macro word does not
+! infer.
+
 : real-macro-effect ( effect -- effect' )
     in>> { "quot" } <effect> ;
 
+PREDICATE: macro-body < memoized "macro-owner" word-prop >boolean ;
+
+: <macro-body> ( word quot effect -- macro-body )
+    real-macro-effect
+    [ name>> "( macro body: " " )" surround <uninterned-word> dup ] 2dip
+    define-memoized ;
+
+M: macro-body crossref? "forgotten" word-prop not ;
+
+M: macro-body reset-word
+    [ call-next-method ] [ "macro-body" remove-word-prop ] bi ;
+
+M: macro-body where "macro-owner" word-prop where ;
+
+: reset-macro ( word -- )
+    [ "macro" word-prop forget ] [ f "macro" set-word-prop ] bi ;
+
 PRIVATE>
 
-: define-macro ( word definition effect -- )
-    real-macro-effect {
-        [ [ memoize-quot [ call ] append ] keep define-declared ]
-        [ drop "macro" set-word-prop ]
-        [ 2drop changed-effect ]
-    } 3cleave ;
+: define-macro ( word quot effect -- )
+    [ 2drop ] [ <macro-body> ] 3bi
+    {
+        [ "macro" set-word-prop ]
+        [ swap "macro-owner" set-word-prop ]
+        [ [ \ call [ ] 2sequence ] [ stack-effect ] bi define-declared ]
+        [ drop changed-effect ]
+    } 2cleave ;
 
 SYNTAX: MACRO: (:) define-macro ;
 
@@ -27,9 +51,12 @@ M: macro make-inline cannot-be-inline ;
 
 M: macro definer drop \ MACRO: \ ; ;
 
-M: macro definition "macro" word-prop ;
+M: macro definition "macro" word-prop definition ;
 
-M: macro reset-word
-    [ call-next-method ] [ f "macro" set-word-prop ] bi ;
+M: macro subwords "macro" word-prop 1array ;
+
+M: macro reset-word [ call-next-method ] [ reset-macro ] bi ;
+
+M: macro forget* [ call-next-method ] [ reset-macro ] bi ;
 
 M: macro always-bump-effect-counter? drop t ;

basis/stack-checker/transforms/transforms.factor

@@ -48,7 +48,7 @@ IN: stack-checker.transforms
 
 : apply-macro ( word -- )
     [ current-word set ]
-    [ "macro" word-prop ]
+    [ "macro" word-prop '[ _ execute ] ]
     [ "declared-effect" word-prop in>> length ] tri
     (apply-transform) ;
 

basis/unix/unix.factor

@@ -9,6 +9,8 @@ sequences stack-checker strings system unix.time unix.types
 vocabs vocabs.loader unix.ffi ;
 IN: unix
 
+<<
+
 ERROR: unix-error errno message ;
 
 : (io-error) ( -- * ) errno dup strerror unix-error ;
@@ -46,6 +48,8 @@ MACRO:: unix-system-call ( quot -- )
         ] if
     ] ;
 
+>>
+
 HOOK: open-file os ( path flags mode -- fd )
 
 : close-file ( fd -- ) [ close ] unix-system-call drop ;
@@ -72,10 +76,6 @@ M: unix open-file [ open ] unix-system-call ;
 
 : unlink-file ( path -- ) [ unlink ] unix-system-call drop ;
 
-<<
-
 "debugger" vocab [
     "unix.debugger" require
 ] when
-
->>