Merge branch 'master' of git://factorcode.org/git/factor
commit
94e1cb413e
|
@ -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 )
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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> ;
|
||||
|
|
|
@ -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." }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 } }
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue