From: Slava Pestov Date: Mon, 1 Feb 2010 05:15:24 +0000 (+1300) Subject: macros: macro body is now defined in its own subword, for compile-time stack effect... X-Git-Tag: 0.97~4980^2~44 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=b7fde7af27d41324c312b5536bf0861aa68c87c7 macros: macro body is now defined in its own subword, for compile-time stack effect checking --- diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 34bac0a505..f3ea7ce8ea 100644 --- a/basis/cocoa/cocoa.factor +++ b/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 diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index 86b13b2ddc..90cc64769a 100644 --- a/basis/cocoa/plists/plists.factor +++ b/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 ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 47ec13e809..fd2962bb16 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/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 } ; diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index 3dab0c3cdb..1dfb663695 100644 --- a/basis/macros/expander/expander.factor +++ b/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 ; diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor index 102bc79c7e..9d9f8f4caf 100644 --- a/basis/macros/macros-docs.factor +++ b/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" diff --git a/basis/macros/macros-tests.factor b/basis/macros/macros-tests.factor index c8dc0ec16d..efc3ff5a30 100644 --- a/basis/macros/macros-tests.factor +++ b/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 diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 46fd1ce748..f2b610cf12 100644 --- a/basis/macros/macros.factor +++ b/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 > { "quot" } ; +PREDICATE: macro-body < memoized "macro-owner" word-prop >boolean ; + +: ( word quot effect -- macro-body ) + real-macro-effect + [ name>> "( macro body: " " )" surround 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 ] [ ] 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 subwords "macro" word-prop 1array ; + +M: macro reset-word [ call-next-method ] [ reset-macro ] bi ; -M: macro reset-word - [ call-next-method ] [ f "macro" set-word-prop ] bi ; +M: macro forget* [ call-next-method ] [ reset-macro ] bi ; M: macro always-bump-effect-counter? drop t ; diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index cf32792a2e..372e621988 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/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) ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 4e77a41713..86a3fc9d6a 100644 --- a/basis/unix/unix.factor +++ b/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 - ->>