From 7de81976a56c53754bf491235a87ba91e2b28a57 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 2 Feb 2010 05:50:13 +1300 Subject: [PATCH] Revert "macros: macro body is now defined in its own subword, for compile-time stack effect checking" This reverts commit 24de7c52f0c3f21cfcdb80235cac7296b0401c85. --- basis/cocoa/cocoa.factor | 15 ++---- basis/cocoa/plists/plists.factor | 7 +++ basis/compiler/tree/debugger/debugger.factor | 47 ++++++++++--------- basis/macros/expander/expander.factor | 31 +++++------- basis/macros/macros-docs.factor | 4 +- basis/macros/macros-tests.factor | 18 ++----- basis/macros/macros.factor | 47 ++++--------------- .../transforms/transforms.factor | 2 +- basis/unix/unix.factor | 8 ++-- 9 files changed, 68 insertions(+), 111 deletions(-) diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index f3ea7ce8ea..34bac0a505 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -1,10 +1,9 @@ -! Copyright (C) 2006, 2010 Slava Pestov +! Copyright (C) 2006, 2009 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 macros quotations fry alien.c-types -arrays combinators ; +compiler.units lexer init ; IN: cocoa : (remember-send) ( selector variable -- ) @@ -15,7 +14,7 @@ SYMBOL: sent-messages : remember-send ( selector -- ) sent-messages (remember-send) ; -SYNTAX: -> scan [ remember-send ] [ suffix! ] bi \ send suffix! ; +SYNTAX: -> scan dup remember-send suffix! \ send suffix! ; SYMBOL: super-sent-messages @@ -34,14 +33,6 @@ 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 90cc64769a..86b13b2ddc 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -40,6 +40,13 @@ 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 c9b60922bd..7350a35de9 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 arrays +sequences sequences.private quotations generic macros arrays prettyprint prettyprint.backend prettyprint.custom prettyprint.sections math words combinators combinators.short-circuit io sorting hints @@ -30,31 +30,34 @@ 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-cond ; + { { { } { } } [ ] } + { { { ?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 ; TUPLE: shuffle-node { effect effect } ; diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index 1dfb663695..3dab0c3cdb 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008, 2010 Slava Pestov. +! Copyright (C) 2008, 2009 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 combinators ; +generalizations fry arrays ; IN: macros.expander GENERIC: expand-macros ( quot -- quot' ) @@ -55,7 +55,7 @@ M: wrapper expand-macros* wrapped>> literal ; : word, ( word -- ) end , ; -: expand-transform ( word quot -- ) +: expand-macro ( word quot -- ) '[ drop stack [ _ with-datastack >vector ] change @@ -65,25 +65,18 @@ M: wrapper expand-macros* wrapped>> literal ; word, ] recover ; -: expand-transform? ( word -- ? ) - dup "transform-quot" word-prop [ - "transform-n" word-prop +: 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 stack get length <= - ] [ drop f ] if ; - -: expand-macro? ( word -- ? ) - dup "macro" word-prop [ - stack-effect in>> length - stack get length <= - ] [ drop f ] if ; + ] [ 2drop f f ] if ; M: word expand-macros* - { - { [ 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 ; + dup expand-dispatch? [ drop expand-dispatch ] [ + dup expand-macro? [ expand-macro ] [ + drop word, + ] if + ] if ; M: object expand-macros* literal ; diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor index 9d9f8f4caf..102bc79c7e 100644 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -47,7 +47,9 @@ $nl $nl "Defining new macros:" { $subsections POSTPONE: MACRO: } -"As with parsing words, macros cannot be used from the same source file that they are defined in." +"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." { $see-also "generalizations" "fry" } ; ABOUT: "macros" diff --git a/basis/macros/macros-tests.factor b/basis/macros/macros-tests.factor index efc3ff5a30..c8dc0ec16d 100644 --- a/basis/macros/macros-tests.factor +++ b/basis/macros/macros-tests.factor @@ -1,7 +1,6 @@ -USING: tools.test macros math kernel arrays -vectors io.streams.string prettyprint parser eval see -stack-checker compiler.units definitions vocabs ; IN: macros.tests +USING: tools.test macros math kernel arrays +vectors io.streams.string prettyprint parser eval see ; MACRO: see-test ( a b -- quot ) + ; @@ -20,18 +19,7 @@ unit-test [ f ] [ \ see-test macro? ] 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 +[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] 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 f2b610cf12..46fd1ce748 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -1,47 +1,23 @@ ! 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 arrays +definitions quotations namespaces memoize accessors 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 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 ; +: define-macro ( word definition effect -- ) + real-macro-effect { + [ [ memoize-quot [ call ] append ] keep define-declared ] + [ drop "macro" set-word-prop ] + [ 2drop changed-effect ] + } 3cleave ; SYNTAX: MACRO: (:) define-macro ; @@ -51,12 +27,9 @@ M: macro make-inline cannot-be-inline ; M: macro definer drop \ MACRO: \ ; ; -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 definition "macro" word-prop ; -M: macro forget* [ call-next-method ] [ reset-macro ] bi ; +M: macro reset-word + [ call-next-method ] [ f "macro" set-word-prop ] 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 372e621988..cf32792a2e 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 '[ _ execute ] ] + [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri (apply-transform) ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 86a3fc9d6a..4e77a41713 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -9,8 +9,6 @@ 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 ; @@ -48,8 +46,6 @@ MACRO:: unix-system-call ( quot -- ) ] if ] ; ->> - HOOK: open-file os ( path flags mode -- fd ) : close-file ( fd -- ) [ close ] unix-system-call drop ; @@ -76,6 +72,10 @@ M: unix open-file [ open ] unix-system-call ; : unlink-file ( path -- ) [ unlink ] unix-system-call drop ; +<< + "debugger" vocab [ "unix.debugger" require ] when + +>> -- 2.34.1