steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

This reverts commit 24de7c52f0c3f21cfcdb80235cac7296b0401c85.
db4
Slava Pestov 2010-02-02 05:50:13 +13:00
parent 13eba38801
commit 7de81976a5
9 changed files with 68 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
basis/cocoa/cocoa.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser cocoa.messages cocoa.types sequences words vocabs parser
core-foundation.bundles namespaces assocs hashtables core-foundation.bundles namespaces assocs hashtables
compiler.units lexer init macros quotations fry alien.c-types compiler.units lexer init ;
arrays combinators ;
IN: cocoa IN: cocoa
: (remember-send) ( selector variable -- ) : (remember-send) ( selector variable -- )
@ -15,7 +14,7 @@ SYMBOL: sent-messages
: remember-send ( selector -- ) : remember-send ( selector -- )
sent-messages (remember-send) ; sent-messages (remember-send) ;
SYNTAX: -> scan [ remember-send ] [ suffix! ] bi \ send suffix! ; SYNTAX: -> scan dup remember-send suffix! \ send suffix! ;
SYMBOL: super-sent-messages SYMBOL: super-sent-messages
@ -34,14 +33,6 @@ SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
SYNTAX: IMPORT: scan [ ] import-objc-class ; 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 "Importing Cocoa classes..." print
"cocoa.classes" create-vocab drop "cocoa.classes" create-vocab drop

7
basis/cocoa/plists/plists.factor
View File

@ -40,6 +40,13 @@ DEFER: plist>
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
*void* [ -> release "read-plist failed" throw ] when* ; *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> PRIVATE>
ERROR: invalid-plist-object object ; ERROR: invalid-plist-object object ;

47
basis/compiler/tree/debugger/debugger.factor
View File

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

31
basis/macros/expander/expander.factor
View File

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

4
basis/macros/macros-docs.factor
View File

@ -47,7 +47,9 @@ $nl
$nl $nl
"Defining new macros:" "Defining new macros:"
{ $subsections POSTPONE: MACRO: } { $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" } ; { $see-also "generalizations" "fry" } ;
ABOUT: "macros" ABOUT: "macros"

18
basis/macros/macros-tests.factor
View File

@ -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 IN: macros.tests
USING: tools.test macros math kernel arrays
vectors io.streams.string prettyprint parser eval see ;
MACRO: see-test ( a b -- quot ) + ; MACRO: see-test ( a b -- quot ) + ;
@ -20,18 +19,7 @@ unit-test
[ f ] [ \ see-test macro? ] 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 stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" 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 ) [ ] ;" eval( -- ) ] unit-test
[ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ; inline" eval( -- ) ] must-fail [ "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

47
basis/macros/macros.factor
View File

@ -1,47 +1,23 @@
! Copyright (C) 2007, 2010 Slava Pestov. ! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects combinators assocs USING: parser kernel sequences words effects combinators assocs
definitions quotations namespaces memoize accessors arrays definitions quotations namespaces memoize accessors
compiler.units ; compiler.units ;
IN: macros IN: macros
<PRIVATE <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' ) : real-macro-effect ( effect -- effect' )
in>> { "quot" } <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> PRIVATE>
: define-macro ( word quot effect -- ) : define-macro ( word definition effect -- )
[ 2drop ] [ <macro-body> ] 3bi real-macro-effect {
{ [ [ memoize-quot [ call ] append ] keep define-declared ]
[ "macro" set-word-prop ] [ drop "macro" set-word-prop ]
[ swap "macro-owner" set-word-prop ] [ 2drop changed-effect ]
[ [ \ call [ ] 2sequence ] [ stack-effect ] bi define-declared ] } 3cleave ;
[ drop changed-effect ]
} 2cleave ;
SYNTAX: MACRO: (:) define-macro ; SYNTAX: MACRO: (:) define-macro ;
@ -51,12 +27,9 @@ M: macro make-inline cannot-be-inline ;
M: macro definer drop \ MACRO: \ ; ; M: macro definer drop \ MACRO: \ ; ;
M: macro definition "macro" word-prop definition ; M: macro definition "macro" word-prop ;
M: macro subwords "macro" word-prop 1array ; M: macro reset-word
[ call-next-method ] [ f "macro" set-word-prop ] bi ;
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 ; M: macro always-bump-effect-counter? drop t ;

2
basis/stack-checker/transforms/transforms.factor
View File

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

8
basis/unix/unix.factor
View File

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