Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-02-04 19:43:59 -06:00
commit 94e1cb413e
11 changed files with 55 additions and 39 deletions

View File

@ -26,7 +26,7 @@ IN: compiler
>r dupd save-effect r>
f pick compiler-error
over compiled-unxref
compiled-xref ;
over crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[

View File

@ -261,6 +261,10 @@ windows? [
cell "ulonglong" c-type set-c-type-align
] unless
macosx? [
cell "double" c-type set-c-type-align
] when
T{ x86-backend f 4 } compiler-backend set-global
: sse2? "Intrinsic" throw ;

View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
combinators ;
@ -41,17 +41,13 @@ M: integer (stack-picture) drop "object" ;
")" %
] "" make ;
: stack-effect ( word -- effect/f )
{
{ [ dup symbol? ] [ drop 0 1 <effect> ] }
{ [ dup "parent-generic" word-prop ] [
"parent-generic" word-prop stack-effect
] }
{ [ t ] [
{ "declared-effect" "inferred-effect" }
swap word-props [ at ] curry map [ ] find nip
] }
} cond ;
GENERIC: stack-effect ( word -- effect/f )
M: symbol stack-effect drop 0 1 <effect> ;
M: word stack-effect
{ "declared-effect" "inferred-effect" }
swap word-props [ at ] curry map [ ] find nip ;
M: effect clone
[ effect-in clone ] keep effect-out clone <effect> ;

View File

@ -107,10 +107,6 @@ HELP: make-generic
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
$low-level-note ;
HELP: init-methods
{ $values { "word" word } }
{ $description "Prepare to define a generic word." } ;
HELP: define-generic
{ $values { "word" word } { "combination" "a method combination" } }
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }

View File

@ -176,6 +176,9 @@ M: f tag-and-f 4 ;
! define-class hashing issue
TUPLE: debug-combination ;
M: debug-combination make-default-method
2drop [ "Oops" throw ] when ;
M: debug-combination perform-combination
drop
order [ dup class-hashes ] { } map>assoc sort-keys

View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
quotations arrays vocabs ;
quotations arrays vocabs effects ;
IN: generic
! Method combination protocol
@ -65,15 +65,20 @@ TUPLE: check-method class generic ;
: make-method-def ( quot word combination -- quot )
"combination" word-prop method-prologue swap append ;
PREDICATE: word method-body "method" word-prop >boolean ;
M: method-body stack-effect
"method" word-prop method-generic stack-effect ;
: <method-word> ( quot class generic -- word )
[ make-method-def ] 2keep
[ method-word-name f <word> dup ] keep
"parent-generic" set-word-prop
method-word-name f <word>
dup rot define ;
: <method> ( quot class generic -- method )
check-method
[ <method-word> ] 3keep f \ method construct-boa ;
[ <method-word> ] 3keep f \ method construct-boa
dup method-word over "method" set-word-prop ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
@ -120,13 +125,22 @@ M: class forget* ( class -- )
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
: init-methods ( word -- )
dup "methods" word-prop
H{ } assoc-like
"methods" set-word-prop ;
: define-generic ( word combination -- )
2dup "combination" set-word-prop
dupd define-default-method
dup init-methods
make-generic ;
over "combination" word-prop over = [
2drop
] [
2dup "combination" set-word-prop
over H{ } clone "methods" set-word-prop
dupd define-default-method
make-generic
] if ;
: subwords ( generic -- seq )
dup "methods" word-prop values
swap "default-method" word-prop add
[ method-word ] map ;
: xref-generics ( -- )
all-words
[ generic? ] subset
[ subwords [ xref ] each ] each ;

View File

@ -10,7 +10,7 @@ TUPLE: standard-combination # ;
M: standard-combination method-prologue
standard-combination-# object
<array> swap add [ declare ] curry ;
<array> swap add* [ declare ] curry ;
C: <standard-combination> standard-combination

View File

@ -10,8 +10,8 @@ IN: inference.backend
recursive-state get at ;
: inline? ( word -- ? )
dup "parent-generic" word-prop
[ inline? ] [ "inline" word-prop ] ?if ;
dup "method" word-prop
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys

View File

@ -116,13 +116,16 @@ SYMBOL: changed-words
[ no-compilation-unit ] unless*
set-at ;
: crossref? ( word -- ? )
dup word-vocabulary swap "method" word-prop or ;
: define ( word def -- )
[ ] like
over unxref
over redefined
over set-word-def
dup changed-word
dup word-vocabulary [ dup xref ] when drop ;
dup crossref? [ dup xref ] when drop ;
: define-declared ( word def effect -- )
pick swap "declared-effect" set-word-prop

View File

@ -146,8 +146,8 @@ HELP: with-process-stream
{ $values
{ "desc" "a launch descriptor" }
{ "quot" quotation }
{ "process" process } }
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ;
{ "status" "an exit code" } }
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" integer } }

View File

@ -98,10 +98,10 @@ TUPLE: process-stream process ;
{ set-delegate set-process-stream-process }
process-stream construct ;
: with-process-stream ( desc quot -- process )
: with-process-stream ( desc quot -- status )
swap <process-stream>
[ swap with-stream ] keep
process-stream-process ; inline
process-stream-process wait-for-process ; inline
: notify-exit ( status process -- )
[ set-process-status ] keep