Fix conflict
Slava Pestov
commit
8da6f2a7f9
|
|
@ -116,16 +116,18 @@ HELP: method-spec
|
|||
{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
|
||||
{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
|
||||
|
||||
HELP: method-body
|
||||
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
|
||||
|
||||
HELP: method
|
||||
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } }
|
||||
{ $description "Looks up a method definition." }
|
||||
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
|
||||
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
|
||||
{ $description "Looks up a method definition." } ;
|
||||
|
||||
{ method define-method POSTPONE: M: } related-words
|
||||
|
||||
HELP: <method>
|
||||
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
|
||||
{ $description "Creates a new "{ $link method } " instance." } ;
|
||||
{ $description "Creates a new method." } ;
|
||||
|
||||
HELP: methods
|
||||
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
|
||||
|
|
|
|||
|
|
@ -33,8 +33,6 @@ M: generic definition drop f ;
|
|||
dup { "unannotated-def" } reset-props
|
||||
dup dup "combination" word-prop perform-combination define ;
|
||||
|
||||
TUPLE: method word def specializer generic loc ;
|
||||
|
||||
: method ( class generic -- method/f )
|
||||
"methods" word-prop at ;
|
||||
|
||||
|
|
@ -47,7 +45,7 @@ PREDICATE: pair method-spec
|
|||
: methods ( word -- assoc )
|
||||
"methods" word-prop
|
||||
[ keys sort-classes ] keep
|
||||
[ dupd at method-word ] curry { } map>assoc ;
|
||||
[ dupd at ] curry { } map>assoc ;
|
||||
|
||||
TUPLE: check-method class generic ;
|
||||
|
||||
|
|
@ -63,29 +61,33 @@ TUPLE: check-method class generic ;
|
|||
: method-word-name ( class word -- string )
|
||||
word-name "/" rot word-name 3append ;
|
||||
|
||||
: make-method-def ( quot word combination -- quot )
|
||||
: make-method-def ( quot class generic -- quot )
|
||||
"combination" word-prop method-prologue swap append ;
|
||||
|
||||
PREDICATE: word method-body "method" word-prop >boolean ;
|
||||
PREDICATE: word method-body "method-def" word-prop >boolean ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"method" word-prop method-generic stack-effect ;
|
||||
"method-generic" word-prop stack-effect ;
|
||||
|
||||
: <method-word> ( quot class generic -- word )
|
||||
[ make-method-def ] 2keep
|
||||
method-word-name f <word>
|
||||
dup rot define
|
||||
dup xref ;
|
||||
: method-word-props ( quot class generic -- assoc )
|
||||
[
|
||||
"method-generic" set
|
||||
"method-class" set
|
||||
"method-def" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: <method> ( quot class generic -- method )
|
||||
: <method> ( quot class generic -- word )
|
||||
check-method
|
||||
[ <method-word> ] 3keep f \ method construct-boa
|
||||
dup method-word over "method" set-word-prop ;
|
||||
[ make-method-def ] 3keep
|
||||
[ method-word-props ] 2keep
|
||||
method-word-name f <word>
|
||||
tuck set-word-props
|
||||
dup rot define ;
|
||||
|
||||
: redefine-method ( quot class generic -- )
|
||||
[ method set-method-def ] 3keep
|
||||
[ method swap "method-def" set-word-prop ] 3keep
|
||||
[ make-method-def ] 2keep
|
||||
method method-word swap define ;
|
||||
method swap define ;
|
||||
|
||||
: define-method ( quot class generic -- )
|
||||
>r bootstrap-word r>
|
||||
|
|
@ -102,21 +104,22 @@ M: method-body stack-effect
|
|||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
dup first2 method [ method-word ] [ second ] ?if where ;
|
||||
dup first2 method [ ] [ second ] ?if where ;
|
||||
|
||||
M: method-spec set-where
|
||||
first2 method method-word set-where ;
|
||||
first2 method set-where ;
|
||||
|
||||
M: method-spec definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-spec definition
|
||||
first2 method dup [ method-def ] when ;
|
||||
first2 method dup
|
||||
[ "method-def" word-prop ] when ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
check-method
|
||||
[ delete-at* ] with-methods
|
||||
[ method-word forget-word ] [ drop ] if ;
|
||||
[ forget-word ] [ drop ] if ;
|
||||
|
||||
M: method-spec forget*
|
||||
first2 forget-method ;
|
||||
|
|
@ -125,11 +128,11 @@ M: method-body definer
|
|||
drop \ M: \ ; ;
|
||||
|
||||
M: method-body definition
|
||||
"method" word-prop method-def ;
|
||||
"method-def" word-prop ;
|
||||
|
||||
M: method-body forget*
|
||||
"method" word-prop
|
||||
{ method-specializer method-generic } get-slots
|
||||
dup "method-class" word-prop
|
||||
swap "method-generic" word-prop
|
||||
forget-method ;
|
||||
|
||||
: implementors* ( classes -- words )
|
||||
|
|
@ -168,8 +171,7 @@ M: word subwords drop f ;
|
|||
|
||||
M: generic subwords
|
||||
dup "methods" word-prop values
|
||||
swap "default-method" word-prop add
|
||||
[ method-word ] map ;
|
||||
swap "default-method" word-prop add ;
|
||||
|
||||
M: generic forget-word
|
||||
dup subwords [ forget-word ] each (forget-word) ;
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
|
|||
|
||||
: applicable-method ( generic class -- quot )
|
||||
over method
|
||||
[ method-word word-def ]
|
||||
[ word-def ]
|
||||
[ default-math-method ] ?if ;
|
||||
|
||||
: object-method ( generic -- quot )
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
|
|||
] if ;
|
||||
|
||||
: default-method ( word -- pair )
|
||||
"default-method" word-prop method-word
|
||||
"default-method" word-prop
|
||||
object bootstrap-word swap 2array ;
|
||||
|
||||
: method-alist>quot ( alist base-class -- quot )
|
||||
|
|
|
|||
|
|
@ -10,8 +10,7 @@ IN: inference.backend
|
|||
recursive-state get at ;
|
||||
|
||||
: inline? ( word -- ? )
|
||||
dup "method" word-prop
|
||||
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
|
||||
dup "method-generic" word-prop swap or "inline" word-prop ;
|
||||
|
||||
: local-recursive-state ( -- assoc )
|
||||
recursive-state get dup keys
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: listener.tests
|
|||
<string-reader> stream-read-quot ;
|
||||
|
||||
[ [ ] ] [
|
||||
"USE: temporary hello" parse-interactive
|
||||
"USE: listener.tests hello" parse-interactive
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,208 +1,208 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes generic.math continuations optimizer.def-use
|
||||
optimizer.backend generic.standard optimizer.specializers
|
||||
optimizer.def-use optimizer.pattern-match generic.standard
|
||||
optimizer.control kernel.private ;
|
||||
IN: optimizer.inlining
|
||||
|
||||
: remember-inlining ( node history -- )
|
||||
[ swap set-node-history ] curry each-node ;
|
||||
|
||||
: inlining-quot ( node quot -- node )
|
||||
over node-in-d dataflow-with
|
||||
dup rot infer-classes/node ;
|
||||
|
||||
: splice-quot ( #call quot history -- node )
|
||||
#! Must add history *before* splicing in, otherwise
|
||||
#! the rest of the IR will also remember the history
|
||||
pick node-history append
|
||||
>r dupd inlining-quot dup r> remember-inlining
|
||||
tuck splice-node ;
|
||||
|
||||
! A heuristic to avoid excessive inlining
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
{
|
||||
! heuristic: { ... } declare comes up in method bodies
|
||||
! and we don't care about it
|
||||
{ [ dup \ declare eq? ] [ drop -2 ] }
|
||||
! recursive
|
||||
{ [ dup get ] [ drop 1 ] }
|
||||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! inline
|
||||
{ [ t ] [ dup dup set word-def (flat-length) ] }
|
||||
} cond ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
{ [ t ] [ drop 1 ] }
|
||||
} cond
|
||||
] map sum ;
|
||||
|
||||
: flat-length ( seq -- n )
|
||||
[ word-def (flat-length) ] with-scope ;
|
||||
|
||||
! Single dispatch method inlining optimization
|
||||
: specific-method ( class word -- class ) order min-class ;
|
||||
|
||||
: node-class# ( node n -- class )
|
||||
over node-in-d <reversed> ?nth node-class ;
|
||||
|
||||
: dispatching-class ( node word -- class )
|
||||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
: inline-standard-method ( node word -- node )
|
||||
2dup dispatching-class dup [
|
||||
over +inlined+ depends-on
|
||||
swap method method-word 1quotation f splice-quot
|
||||
] [
|
||||
3drop t
|
||||
] if ;
|
||||
|
||||
! Partial dispatch of math-generic words
|
||||
: math-both-known? ( word left right -- ? )
|
||||
math-class-max swap specific-method ;
|
||||
|
||||
: inline-math-method ( #call word -- node )
|
||||
over node-input-classes first2 3dup math-both-known?
|
||||
[ math-method f splice-quot ] [ 2drop 2drop t ] if ;
|
||||
|
||||
: inline-method ( #call -- node )
|
||||
dup node-param {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
} cond ;
|
||||
|
||||
! Resolve type checks at compile time where possible
|
||||
: comparable? ( actual testing -- ? )
|
||||
#! If actual is a subset of testing or if the two classes
|
||||
#! are disjoint, return t.
|
||||
2dup class< >r classes-intersect? not r> or ;
|
||||
|
||||
: optimize-predicate? ( #call -- ? )
|
||||
dup node-param "predicating" word-prop dup [
|
||||
>r node-class-first r> comparable?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: literal-quot ( node literals -- quot )
|
||||
#! Outputs a quotation which drops the node's inputs, and
|
||||
#! pushes some literals.
|
||||
>r node-in-d length \ drop <repetition>
|
||||
r> [ literalize ] map append >quotation ;
|
||||
|
||||
: inline-literals ( node literals -- node )
|
||||
#! Make #shuffle -> #push -> #return -> successor
|
||||
dupd literal-quot f splice-quot ;
|
||||
|
||||
: evaluate-predicate ( #call -- ? )
|
||||
dup node-param "predicating" word-prop >r
|
||||
node-class-first r> class< ;
|
||||
|
||||
: optimize-predicate ( #call -- node )
|
||||
#! If the predicate is followed by a branch we fold it
|
||||
#! immediately
|
||||
dup evaluate-predicate swap
|
||||
dup node-successor #if? [
|
||||
dup drop-inputs >r
|
||||
node-successor swap 0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep
|
||||
] [
|
||||
swap 1array inline-literals
|
||||
] if ;
|
||||
|
||||
: optimizer-hooks ( node -- conditions )
|
||||
node-param "optimizer-hooks" word-prop ;
|
||||
|
||||
: optimizer-hook ( node -- pair/f )
|
||||
dup optimizer-hooks [ first call ] find 2nip ;
|
||||
|
||||
: optimize-hook ( node -- )
|
||||
dup optimizer-hook second call ;
|
||||
|
||||
: define-optimizers ( word optimizers -- )
|
||||
"optimizer-hooks" set-word-prop ;
|
||||
|
||||
: flush-eval? ( #call -- ? )
|
||||
dup node-param "flushable" word-prop [
|
||||
node-out-d [ unused? ] all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: flush-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup node-out-d length f <repetition> inline-literals ;
|
||||
|
||||
: partial-eval? ( #call -- ? )
|
||||
dup node-param "foldable" word-prop [
|
||||
dup node-in-d [ node-literal? ] with all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: literal-in-d ( #call -- inputs )
|
||||
dup node-in-d [ node-literal ] with map ;
|
||||
|
||||
: partial-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup literal-in-d over node-param 1quotation
|
||||
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
|
||||
|
||||
: define-identities ( words identities -- )
|
||||
[ "identities" set-word-prop ] curry each ;
|
||||
|
||||
: find-identity ( node -- quot )
|
||||
[ node-param "identities" word-prop ] keep
|
||||
[ swap first in-d-match? ] curry find
|
||||
nip dup [ second ] when ;
|
||||
|
||||
: apply-identities ( node -- node/f )
|
||||
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
|
||||
|
||||
: optimistic-inline? ( #call -- ? )
|
||||
dup node-param "specializer" word-prop dup [
|
||||
>r node-input-classes r> specialized-length tail*
|
||||
[ types length 1 = ] all?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: splice-word-def ( #call word -- node )
|
||||
dup +inlined+ depends-on
|
||||
dup word-def swap 1array splice-quot ;
|
||||
|
||||
: optimistic-inline ( #call -- node )
|
||||
dup node-param over node-history memq? [
|
||||
drop t
|
||||
] [
|
||||
dup node-param splice-word-def
|
||||
] if ;
|
||||
|
||||
: method-body-inline? ( #call -- ? )
|
||||
node-param dup method-body?
|
||||
[ flat-length 10 <= ] [ drop f ] if ;
|
||||
|
||||
M: #call optimize-node*
|
||||
{
|
||||
{ [ dup flush-eval? ] [ flush-eval ] }
|
||||
{ [ dup partial-eval? ] [ partial-eval ] }
|
||||
{ [ dup find-identity ] [ apply-identities ] }
|
||||
{ [ dup optimizer-hook ] [ optimize-hook ] }
|
||||
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
|
||||
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
|
||||
{ [ dup method-body-inline? ] [ optimistic-inline ] }
|
||||
{ [ t ] [ inline-method ] }
|
||||
} cond dup not ;
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs inference inference.class
|
||||
inference.dataflow inference.backend inference.state io kernel
|
||||
math namespaces sequences vectors words quotations hashtables
|
||||
combinators classes generic.math continuations optimizer.def-use
|
||||
optimizer.backend generic.standard optimizer.specializers
|
||||
optimizer.def-use optimizer.pattern-match generic.standard
|
||||
optimizer.control kernel.private ;
|
||||
IN: optimizer.inlining
|
||||
|
||||
: remember-inlining ( node history -- )
|
||||
[ swap set-node-history ] curry each-node ;
|
||||
|
||||
: inlining-quot ( node quot -- node )
|
||||
over node-in-d dataflow-with
|
||||
dup rot infer-classes/node ;
|
||||
|
||||
: splice-quot ( #call quot history -- node )
|
||||
#! Must add history *before* splicing in, otherwise
|
||||
#! the rest of the IR will also remember the history
|
||||
pick node-history append
|
||||
>r dupd inlining-quot dup r> remember-inlining
|
||||
tuck splice-node ;
|
||||
|
||||
! A heuristic to avoid excessive inlining
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
{
|
||||
! heuristic: { ... } declare comes up in method bodies
|
||||
! and we don't care about it
|
||||
{ [ dup \ declare eq? ] [ drop -2 ] }
|
||||
! recursive
|
||||
{ [ dup get ] [ drop 1 ] }
|
||||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! inline
|
||||
{ [ t ] [ dup dup set word-def (flat-length) ] }
|
||||
} cond ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
{ [ t ] [ drop 1 ] }
|
||||
} cond
|
||||
] map sum ;
|
||||
|
||||
: flat-length ( seq -- n )
|
||||
[ word-def (flat-length) ] with-scope ;
|
||||
|
||||
! Single dispatch method inlining optimization
|
||||
: specific-method ( class word -- class ) order min-class ;
|
||||
|
||||
: node-class# ( node n -- class )
|
||||
over node-in-d <reversed> ?nth node-class ;
|
||||
|
||||
: dispatching-class ( node word -- class )
|
||||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
: inline-standard-method ( node word -- node )
|
||||
2dup dispatching-class dup [
|
||||
over +inlined+ depends-on
|
||||
swap method 1quotation f splice-quot
|
||||
] [
|
||||
3drop t
|
||||
] if ;
|
||||
|
||||
! Partial dispatch of math-generic words
|
||||
: math-both-known? ( word left right -- ? )
|
||||
math-class-max swap specific-method ;
|
||||
|
||||
: inline-math-method ( #call word -- node )
|
||||
over node-input-classes first2 3dup math-both-known?
|
||||
[ math-method f splice-quot ] [ 2drop 2drop t ] if ;
|
||||
|
||||
: inline-method ( #call -- node )
|
||||
dup node-param {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
} cond ;
|
||||
|
||||
! Resolve type checks at compile time where possible
|
||||
: comparable? ( actual testing -- ? )
|
||||
#! If actual is a subset of testing or if the two classes
|
||||
#! are disjoint, return t.
|
||||
2dup class< >r classes-intersect? not r> or ;
|
||||
|
||||
: optimize-predicate? ( #call -- ? )
|
||||
dup node-param "predicating" word-prop dup [
|
||||
>r node-class-first r> comparable?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: literal-quot ( node literals -- quot )
|
||||
#! Outputs a quotation which drops the node's inputs, and
|
||||
#! pushes some literals.
|
||||
>r node-in-d length \ drop <repetition>
|
||||
r> [ literalize ] map append >quotation ;
|
||||
|
||||
: inline-literals ( node literals -- node )
|
||||
#! Make #shuffle -> #push -> #return -> successor
|
||||
dupd literal-quot f splice-quot ;
|
||||
|
||||
: evaluate-predicate ( #call -- ? )
|
||||
dup node-param "predicating" word-prop >r
|
||||
node-class-first r> class< ;
|
||||
|
||||
: optimize-predicate ( #call -- node )
|
||||
#! If the predicate is followed by a branch we fold it
|
||||
#! immediately
|
||||
dup evaluate-predicate swap
|
||||
dup node-successor #if? [
|
||||
dup drop-inputs >r
|
||||
node-successor swap 0 1 ? fold-branch
|
||||
r> [ set-node-successor ] keep
|
||||
] [
|
||||
swap 1array inline-literals
|
||||
] if ;
|
||||
|
||||
: optimizer-hooks ( node -- conditions )
|
||||
node-param "optimizer-hooks" word-prop ;
|
||||
|
||||
: optimizer-hook ( node -- pair/f )
|
||||
dup optimizer-hooks [ first call ] find 2nip ;
|
||||
|
||||
: optimize-hook ( node -- )
|
||||
dup optimizer-hook second call ;
|
||||
|
||||
: define-optimizers ( word optimizers -- )
|
||||
"optimizer-hooks" set-word-prop ;
|
||||
|
||||
: flush-eval? ( #call -- ? )
|
||||
dup node-param "flushable" word-prop [
|
||||
node-out-d [ unused? ] all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: flush-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup node-out-d length f <repetition> inline-literals ;
|
||||
|
||||
: partial-eval? ( #call -- ? )
|
||||
dup node-param "foldable" word-prop [
|
||||
dup node-in-d [ node-literal? ] with all?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: literal-in-d ( #call -- inputs )
|
||||
dup node-in-d [ node-literal ] with map ;
|
||||
|
||||
: partial-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup literal-in-d over node-param 1quotation
|
||||
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
|
||||
|
||||
: define-identities ( words identities -- )
|
||||
[ "identities" set-word-prop ] curry each ;
|
||||
|
||||
: find-identity ( node -- quot )
|
||||
[ node-param "identities" word-prop ] keep
|
||||
[ swap first in-d-match? ] curry find
|
||||
nip dup [ second ] when ;
|
||||
|
||||
: apply-identities ( node -- node/f )
|
||||
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
|
||||
|
||||
: optimistic-inline? ( #call -- ? )
|
||||
dup node-param "specializer" word-prop dup [
|
||||
>r node-input-classes r> specialized-length tail*
|
||||
[ types length 1 = ] all?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: splice-word-def ( #call word -- node )
|
||||
dup +inlined+ depends-on
|
||||
dup word-def swap 1array splice-quot ;
|
||||
|
||||
: optimistic-inline ( #call -- node )
|
||||
dup node-param over node-history memq? [
|
||||
drop t
|
||||
] [
|
||||
dup node-param splice-word-def
|
||||
] if ;
|
||||
|
||||
: method-body-inline? ( #call -- ? )
|
||||
node-param dup method-body?
|
||||
[ flat-length 10 <= ] [ drop f ] if ;
|
||||
|
||||
M: #call optimize-node*
|
||||
{
|
||||
{ [ dup flush-eval? ] [ flush-eval ] }
|
||||
{ [ dup partial-eval? ] [ partial-eval ] }
|
||||
{ [ dup find-identity ] [ apply-identities ] }
|
||||
{ [ dup optimizer-hook ] [ optimize-hook ] }
|
||||
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
|
||||
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
|
||||
{ [ dup method-body-inline? ] [ optimistic-inline ] }
|
||||
{ [ t ] [ inline-method ] }
|
||||
} cond dup not ;
|
||||
|
|
|
|||
|
|
@ -1,378 +1,378 @@
|
|||
USING: arrays compiler.units generic hashtables inference kernel
|
||||
kernel.private math optimizer prettyprint sequences sbufs
|
||||
strings tools.test vectors words sequences.private quotations
|
||||
optimizer.backend classes inference.dataflow tuples.private
|
||||
continuations growable optimizer.inlining namespaces hints ;
|
||||
IN: optimizer.tests
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
|
||||
] unit-test
|
||||
|
||||
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
|
||||
] unit-test
|
||||
|
||||
! Test method inlining
|
||||
[ f ] [ fixnum { } min-class ] unit-test
|
||||
|
||||
[ string ] [
|
||||
\ string
|
||||
[ integer string array reversed sbuf
|
||||
slice vector quotation ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [
|
||||
\ fixnum
|
||||
[ fixnum integer object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ integer ] [
|
||||
\ fixnum
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ object ] [
|
||||
\ word
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ reversed ] [
|
||||
\ reversed
|
||||
[ integer reversed slice ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
[ t ] [ \ xyz compiled? ] unit-test
|
||||
|
||||
! Test predicate inlining
|
||||
: pred-test-1
|
||||
dup fixnum? [
|
||||
dup integer? [ "integer" ] [ "nope" ] if
|
||||
] [
|
||||
"not a fixnum"
|
||||
] if ;
|
||||
|
||||
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
|
||||
|
||||
TUPLE: pred-test ;
|
||||
|
||||
: pred-test-2
|
||||
dup tuple? [
|
||||
dup pred-test? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
|
||||
|
||||
: pred-test-3
|
||||
dup pred-test? [
|
||||
dup tuple? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
|
||||
|
||||
: inline-test
|
||||
"nom" = ;
|
||||
|
||||
[ t ] [ "nom" inline-test ] unit-test
|
||||
[ f ] [ "shayin" inline-test ] unit-test
|
||||
[ f ] [ 3 inline-test ] unit-test
|
||||
|
||||
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
|
||||
|
||||
[ ] [ 1000000 fixnum-declarations . ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: literal-not-branch 0 not [ ] [ ] if ;
|
||||
|
||||
[ ] [ literal-not-branch ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
|
||||
: bad-kill-2 bad-kill-1 drop ;
|
||||
|
||||
[ 3 ] [ t bad-kill-2 ] unit-test
|
||||
|
||||
! regression
|
||||
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
|
||||
: the-test ( -- x y ) 2 dup (the-test) ;
|
||||
|
||||
[ 2 0 ] [ the-test ] unit-test
|
||||
|
||||
! regression
|
||||
: (double-recursion) ( start end -- )
|
||||
< [
|
||||
6 1 (double-recursion)
|
||||
3 2 (double-recursion)
|
||||
] when ; inline
|
||||
|
||||
: double-recursion 0 2 (double-recursion) ;
|
||||
|
||||
[ ] [ double-recursion ] unit-test
|
||||
|
||||
! regression
|
||||
: double-label-1 ( a b c -- d )
|
||||
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
|
||||
|
||||
: double-label-2 ( a -- b )
|
||||
dup array? [ ] [ ] if 0 t double-label-1 ;
|
||||
|
||||
[ 0 ] [ 10 double-label-2 ] unit-test
|
||||
|
||||
! regression
|
||||
GENERIC: void-generic ( obj -- * )
|
||||
: breakage "hi" void-generic ;
|
||||
[ t ] [ \ breakage compiled? ] unit-test
|
||||
[ breakage ] must-fail
|
||||
|
||||
! regression
|
||||
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
|
||||
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
|
||||
: test-2 ( -- ) 5 test-1 ;
|
||||
|
||||
[ f ] [ f test-2 ] unit-test
|
||||
|
||||
: branch-fold-regression-0 ( m -- n )
|
||||
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
|
||||
|
||||
: branch-fold-regression-1 ( -- m )
|
||||
10 branch-fold-regression-0 ;
|
||||
|
||||
[ 10 ] [ branch-fold-regression-1 ] unit-test
|
||||
|
||||
! another regression
|
||||
: constant-branch-fold-0 "hey" ; foldable
|
||||
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
|
||||
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
|
||||
! another regression
|
||||
: foo f ;
|
||||
: bar foo 4 4 = and ;
|
||||
[ f ] [ bar ] unit-test
|
||||
|
||||
! ensure identities are working in some form
|
||||
[ t ] [
|
||||
[ { number } declare 0 + ] dataflow optimize
|
||||
[ #push? ] node-exists? not
|
||||
] unit-test
|
||||
|
||||
! compiling <tuple> with a non-literal class failed
|
||||
: <tuple>-regression <tuple> ;
|
||||
|
||||
[ t ] [ \ <tuple>-regression compiled? ] unit-test
|
||||
|
||||
GENERIC: foozul ( a -- b )
|
||||
M: reversed foozul ;
|
||||
M: integer foozul ;
|
||||
M: slice foozul ;
|
||||
|
||||
[ reversed ] [ reversed \ foozul specific-method ] unit-test
|
||||
|
||||
! regression
|
||||
: constant-fold-2 f ; foldable
|
||||
: constant-fold-3 4 ; foldable
|
||||
|
||||
[ f t ] [
|
||||
[ constant-fold-2 constant-fold-3 4 = ] compile-call
|
||||
] unit-test
|
||||
|
||||
: constant-fold-4 f ; foldable
|
||||
: constant-fold-5 f ; foldable
|
||||
|
||||
[ f ] [
|
||||
[ constant-fold-4 constant-fold-5 or ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
|
||||
|
||||
[ f ] [ 5 [ dup < ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup <= ] compile-call ] unit-test
|
||||
[ f ] [ 5 [ dup > ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup >= ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup = ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup number= ] compile-call ] unit-test
|
||||
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
|
||||
|
||||
GENERIC: detect-number ( obj -- obj )
|
||||
M: number detect-number ;
|
||||
|
||||
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
|
||||
|
||||
! Regression
|
||||
USE: sorting
|
||||
USE: sorting.private
|
||||
|
||||
: old-binsearch ( elt quot seq -- elt quot i )
|
||||
dup length 1 <= [
|
||||
slice-from
|
||||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ drop dup slice-from swap midpoint@ + ]
|
||||
[ partition old-binsearch ] if
|
||||
] if ; inline
|
||||
|
||||
[ 10 ] [
|
||||
10 20 >vector <flat-slice>
|
||||
[ [ - ] swap old-binsearch ] compile-call 2nip
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
TUPLE: silly-tuple a b ;
|
||||
|
||||
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
|
||||
T{ silly-tuple f 1 2 }
|
||||
[
|
||||
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
: empty-compound ;
|
||||
|
||||
: node-successor-f-bug ( x -- * )
|
||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
||||
|
||||
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
|
||||
|
||||
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
|
||||
|
||||
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
|
||||
|
||||
! Make sure we have sane heuristics
|
||||
: should-inline? method method-word flat-length 10 <= ;
|
||||
|
||||
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
|
||||
[ f ] [ \ array \ equal? should-inline? ] unit-test
|
||||
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
|
||||
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
|
||||
|
||||
! Regression
|
||||
: lift-throw-tail-regression
|
||||
dup integer? [ "an integer" ] [
|
||||
dup string? [ "a string" ] [
|
||||
"error" throw
|
||||
] if
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
|
||||
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
|
||||
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
|
||||
|
||||
: lift-loop-tail-test-1 ( a quot -- )
|
||||
over even? [
|
||||
[ >r 3 - r> call ] keep lift-loop-tail-test-1
|
||||
] [
|
||||
over 0 < [
|
||||
2drop
|
||||
] [
|
||||
[ >r 2 - r> call ] keep lift-loop-tail-test-1
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: lift-loop-tail-test-2
|
||||
10 [ ] lift-loop-tail-test-1 1 2 3 ;
|
||||
|
||||
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
|
||||
|
||||
! Make sure we don't lose
|
||||
GENERIC: generic-inline-test ( x -- y )
|
||||
M: integer generic-inline-test ;
|
||||
|
||||
: generic-inline-test-1
|
||||
1
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test ;
|
||||
|
||||
[ { t f } ] [
|
||||
\ generic-inline-test-1 word-def dataflow
|
||||
[ optimize-1 , optimize-1 , drop ] { } make
|
||||
] unit-test
|
||||
|
||||
! Forgot a recursive inline check
|
||||
: recursive-inline-hang ( a -- a )
|
||||
dup array? [ recursive-inline-hang ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang array ;
|
||||
|
||||
: recursive-inline-hang-1
|
||||
{ } recursive-inline-hang ;
|
||||
|
||||
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
|
||||
|
||||
DEFER: recursive-inline-hang-3
|
||||
|
||||
: recursive-inline-hang-2 ( a -- a )
|
||||
dup array? [ recursive-inline-hang-3 ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang-2 array ;
|
||||
|
||||
: recursive-inline-hang-3 ( a -- a )
|
||||
dup array? [ recursive-inline-hang-2 ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang-3 array ;
|
||||
|
||||
|
||||
USING: arrays compiler.units generic hashtables inference kernel
|
||||
kernel.private math optimizer prettyprint sequences sbufs
|
||||
strings tools.test vectors words sequences.private quotations
|
||||
optimizer.backend classes inference.dataflow tuples.private
|
||||
continuations growable optimizer.inlining namespaces hints ;
|
||||
IN: optimizer.tests
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
|
||||
] unit-test
|
||||
|
||||
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
|
||||
] unit-test
|
||||
|
||||
! Test method inlining
|
||||
[ f ] [ fixnum { } min-class ] unit-test
|
||||
|
||||
[ string ] [
|
||||
\ string
|
||||
[ integer string array reversed sbuf
|
||||
slice vector quotation ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [
|
||||
\ fixnum
|
||||
[ fixnum integer object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ integer ] [
|
||||
\ fixnum
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ object ] [
|
||||
\ word
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ reversed ] [
|
||||
\ reversed
|
||||
[ integer reversed slice ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
[ t ] [ \ xyz compiled? ] unit-test
|
||||
|
||||
! Test predicate inlining
|
||||
: pred-test-1
|
||||
dup fixnum? [
|
||||
dup integer? [ "integer" ] [ "nope" ] if
|
||||
] [
|
||||
"not a fixnum"
|
||||
] if ;
|
||||
|
||||
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
|
||||
|
||||
TUPLE: pred-test ;
|
||||
|
||||
: pred-test-2
|
||||
dup tuple? [
|
||||
dup pred-test? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
|
||||
|
||||
: pred-test-3
|
||||
dup pred-test? [
|
||||
dup tuple? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
|
||||
|
||||
: inline-test
|
||||
"nom" = ;
|
||||
|
||||
[ t ] [ "nom" inline-test ] unit-test
|
||||
[ f ] [ "shayin" inline-test ] unit-test
|
||||
[ f ] [ 3 inline-test ] unit-test
|
||||
|
||||
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
|
||||
|
||||
[ ] [ 1000000 fixnum-declarations . ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: literal-not-branch 0 not [ ] [ ] if ;
|
||||
|
||||
[ ] [ literal-not-branch ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
|
||||
: bad-kill-2 bad-kill-1 drop ;
|
||||
|
||||
[ 3 ] [ t bad-kill-2 ] unit-test
|
||||
|
||||
! regression
|
||||
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
|
||||
: the-test ( -- x y ) 2 dup (the-test) ;
|
||||
|
||||
[ 2 0 ] [ the-test ] unit-test
|
||||
|
||||
! regression
|
||||
: (double-recursion) ( start end -- )
|
||||
< [
|
||||
6 1 (double-recursion)
|
||||
3 2 (double-recursion)
|
||||
] when ; inline
|
||||
|
||||
: double-recursion 0 2 (double-recursion) ;
|
||||
|
||||
[ ] [ double-recursion ] unit-test
|
||||
|
||||
! regression
|
||||
: double-label-1 ( a b c -- d )
|
||||
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
|
||||
|
||||
: double-label-2 ( a -- b )
|
||||
dup array? [ ] [ ] if 0 t double-label-1 ;
|
||||
|
||||
[ 0 ] [ 10 double-label-2 ] unit-test
|
||||
|
||||
! regression
|
||||
GENERIC: void-generic ( obj -- * )
|
||||
: breakage "hi" void-generic ;
|
||||
[ t ] [ \ breakage compiled? ] unit-test
|
||||
[ breakage ] must-fail
|
||||
|
||||
! regression
|
||||
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
|
||||
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
|
||||
: test-2 ( -- ) 5 test-1 ;
|
||||
|
||||
[ f ] [ f test-2 ] unit-test
|
||||
|
||||
: branch-fold-regression-0 ( m -- n )
|
||||
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
|
||||
|
||||
: branch-fold-regression-1 ( -- m )
|
||||
10 branch-fold-regression-0 ;
|
||||
|
||||
[ 10 ] [ branch-fold-regression-1 ] unit-test
|
||||
|
||||
! another regression
|
||||
: constant-branch-fold-0 "hey" ; foldable
|
||||
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
|
||||
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
|
||||
! another regression
|
||||
: foo f ;
|
||||
: bar foo 4 4 = and ;
|
||||
[ f ] [ bar ] unit-test
|
||||
|
||||
! ensure identities are working in some form
|
||||
[ t ] [
|
||||
[ { number } declare 0 + ] dataflow optimize
|
||||
[ #push? ] node-exists? not
|
||||
] unit-test
|
||||
|
||||
! compiling <tuple> with a non-literal class failed
|
||||
: <tuple>-regression <tuple> ;
|
||||
|
||||
[ t ] [ \ <tuple>-regression compiled? ] unit-test
|
||||
|
||||
GENERIC: foozul ( a -- b )
|
||||
M: reversed foozul ;
|
||||
M: integer foozul ;
|
||||
M: slice foozul ;
|
||||
|
||||
[ reversed ] [ reversed \ foozul specific-method ] unit-test
|
||||
|
||||
! regression
|
||||
: constant-fold-2 f ; foldable
|
||||
: constant-fold-3 4 ; foldable
|
||||
|
||||
[ f t ] [
|
||||
[ constant-fold-2 constant-fold-3 4 = ] compile-call
|
||||
] unit-test
|
||||
|
||||
: constant-fold-4 f ; foldable
|
||||
: constant-fold-5 f ; foldable
|
||||
|
||||
[ f ] [
|
||||
[ constant-fold-4 constant-fold-5 or ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
|
||||
|
||||
[ f ] [ 5 [ dup < ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup <= ] compile-call ] unit-test
|
||||
[ f ] [ 5 [ dup > ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup >= ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup = ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup number= ] compile-call ] unit-test
|
||||
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
|
||||
|
||||
GENERIC: detect-number ( obj -- obj )
|
||||
M: number detect-number ;
|
||||
|
||||
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
|
||||
|
||||
! Regression
|
||||
USE: sorting
|
||||
USE: sorting.private
|
||||
|
||||
: old-binsearch ( elt quot seq -- elt quot i )
|
||||
dup length 1 <= [
|
||||
slice-from
|
||||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ drop dup slice-from swap midpoint@ + ]
|
||||
[ partition old-binsearch ] if
|
||||
] if ; inline
|
||||
|
||||
[ 10 ] [
|
||||
10 20 >vector <flat-slice>
|
||||
[ [ - ] swap old-binsearch ] compile-call 2nip
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
TUPLE: silly-tuple a b ;
|
||||
|
||||
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
|
||||
T{ silly-tuple f 1 2 }
|
||||
[
|
||||
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
: empty-compound ;
|
||||
|
||||
: node-successor-f-bug ( x -- * )
|
||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
||||
|
||||
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
|
||||
|
||||
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
|
||||
|
||||
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
|
||||
|
||||
! Make sure we have sane heuristics
|
||||
: should-inline? method flat-length 10 <= ;
|
||||
|
||||
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
|
||||
[ f ] [ \ array \ equal? should-inline? ] unit-test
|
||||
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
|
||||
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
|
||||
|
||||
! Regression
|
||||
: lift-throw-tail-regression
|
||||
dup integer? [ "an integer" ] [
|
||||
dup string? [ "a string" ] [
|
||||
"error" throw
|
||||
] if
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
|
||||
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
|
||||
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
|
||||
|
||||
: lift-loop-tail-test-1 ( a quot -- )
|
||||
over even? [
|
||||
[ >r 3 - r> call ] keep lift-loop-tail-test-1
|
||||
] [
|
||||
over 0 < [
|
||||
2drop
|
||||
] [
|
||||
[ >r 2 - r> call ] keep lift-loop-tail-test-1
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: lift-loop-tail-test-2
|
||||
10 [ ] lift-loop-tail-test-1 1 2 3 ;
|
||||
|
||||
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
|
||||
|
||||
! Make sure we don't lose
|
||||
GENERIC: generic-inline-test ( x -- y )
|
||||
M: integer generic-inline-test ;
|
||||
|
||||
: generic-inline-test-1
|
||||
1
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test
|
||||
generic-inline-test ;
|
||||
|
||||
[ { t f } ] [
|
||||
\ generic-inline-test-1 word-def dataflow
|
||||
[ optimize-1 , optimize-1 , drop ] { } make
|
||||
] unit-test
|
||||
|
||||
! Forgot a recursive inline check
|
||||
: recursive-inline-hang ( a -- a )
|
||||
dup array? [ recursive-inline-hang ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang array ;
|
||||
|
||||
: recursive-inline-hang-1
|
||||
{ } recursive-inline-hang ;
|
||||
|
||||
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
|
||||
|
||||
DEFER: recursive-inline-hang-3
|
||||
|
||||
: recursive-inline-hang-2 ( a -- a )
|
||||
dup array? [ recursive-inline-hang-3 ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang-2 array ;
|
||||
|
||||
: recursive-inline-hang-3 ( a -- a )
|
||||
dup array? [ recursive-inline-hang-2 ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang-3 array ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ IN: parser.tests
|
|||
[ "hello world" ]
|
||||
[
|
||||
"IN: parser.tests : hello \"hello world\" ;"
|
||||
eval "USE: temporary hello" eval
|
||||
eval "USE: parser.tests hello" eval
|
||||
] unit-test
|
||||
|
||||
[ ]
|
||||
|
|
@ -104,12 +104,12 @@ IN: parser.tests
|
|||
|
||||
"IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval
|
||||
|
||||
[ ] [ "USE: temporary foo" eval ] unit-test
|
||||
[ ] [ "USE: parser.tests foo" eval ] unit-test
|
||||
|
||||
"IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval
|
||||
|
||||
[ t ] [
|
||||
"USE: temporary \\ foo" eval
|
||||
"USE: parser.tests \\ foo" eval
|
||||
"foo" "parser.tests" lookup eq?
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -125,18 +125,18 @@ unit-test
|
|||
"IN: prettyprint.tests"
|
||||
"GENERIC: method-layout"
|
||||
""
|
||||
"USING: math temporary ;"
|
||||
"USING: math prettyprint.tests ;"
|
||||
"M: complex method-layout"
|
||||
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
|
||||
" ;"
|
||||
""
|
||||
"USING: math temporary ;"
|
||||
"USING: math prettyprint.tests ;"
|
||||
"M: fixnum method-layout ;"
|
||||
""
|
||||
"USING: math temporary ;"
|
||||
"USING: math prettyprint.tests ;"
|
||||
"M: integer method-layout ;"
|
||||
""
|
||||
"USING: kernel temporary ;"
|
||||
"USING: kernel prettyprint.tests ;"
|
||||
"M: object method-layout ;"
|
||||
} ;
|
||||
|
||||
|
|
@ -280,7 +280,7 @@ unit-test
|
|||
"IN: prettyprint.tests"
|
||||
"GENERIC: class-see-layout ( x -- y )"
|
||||
""
|
||||
"USING: temporary ;"
|
||||
"USING: prettyprint.tests ;"
|
||||
"M: class-see-layout class-see-layout ;"
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -175,10 +175,10 @@ M: method-spec synopsis*
|
|||
dup definer. [ pprint-word ] each ;
|
||||
|
||||
M: method-body synopsis*
|
||||
dup definer.
|
||||
"method" word-prop dup
|
||||
method-specializer pprint*
|
||||
method-generic pprint* ;
|
||||
dup dup
|
||||
definer.
|
||||
"method-class" word-prop pprint*
|
||||
"method-generic" word-prop pprint* ;
|
||||
|
||||
M: mixin-instance synopsis*
|
||||
dup definer.
|
||||
|
|
@ -269,7 +269,7 @@ M: builtin-class see-class*
|
|||
|
||||
: see-implementors ( class -- seq )
|
||||
dup implementors
|
||||
[ method method-word ] with map
|
||||
[ method ] with map
|
||||
natural-sort ;
|
||||
|
||||
: see-class ( class -- )
|
||||
|
|
@ -280,9 +280,7 @@ M: builtin-class see-class*
|
|||
] when drop ;
|
||||
|
||||
: see-methods ( generic -- seq )
|
||||
"methods" word-prop
|
||||
[ nip method-word ] { } assoc>map
|
||||
natural-sort ;
|
||||
"methods" word-prop values natural-sort ;
|
||||
|
||||
M: word see
|
||||
dup see-class
|
||||
|
|
|
|||
|
|
@ -68,7 +68,10 @@ uses definitions ;
|
|||
: reset-checksums ( -- )
|
||||
source-files get [
|
||||
swap ?resource-path dup exists?
|
||||
[ file-lines swap record-checksum ] [ 2drop ] if
|
||||
[
|
||||
over record-modified
|
||||
file-lines swap record-checksum
|
||||
] [ 2drop ] if
|
||||
] assoc-each ;
|
||||
|
||||
M: pathname where pathname-string 1 2array ;
|
||||
|
|
|
|||
|
|
@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ;
|
|||
|
||||
M: f set-vocab-docs-loaded? 2drop ;
|
||||
|
||||
M: f vocab-help ;
|
||||
|
||||
: create-vocab ( name -- vocab )
|
||||
dictionary get [ <vocab> ] cache ;
|
||||
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
|
|||
: crossref? ( word -- ? )
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ f ] }
|
||||
{ [ dup "method" word-prop ] [ t ] }
|
||||
{ [ dup "method-definition" word-prop ] [ t ] }
|
||||
{ [ dup word-vocabulary ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
|
|
|||
|
|
@ -1,65 +1,58 @@
|
|||
USING: io.sockets io kernel math threads
|
||||
debugger tools.time prettyprint concurrency.count-downs
|
||||
namespaces arrays continuations ;
|
||||
IN: benchmark.sockets
|
||||
|
||||
SYMBOL: counter
|
||||
|
||||
: number-of-requests 1 ;
|
||||
|
||||
: server-addr "127.0.0.1" 7777 <inet4> ;
|
||||
|
||||
: server-loop ( server -- )
|
||||
dup accept [
|
||||
[
|
||||
read1 CHAR: x = [
|
||||
"server" get dispose
|
||||
] [
|
||||
number-of-requests
|
||||
[ read1 write1 flush ] times
|
||||
counter get count-down
|
||||
] if
|
||||
] with-stream
|
||||
] curry "Client handler" spawn drop server-loop ;
|
||||
|
||||
: simple-server ( -- )
|
||||
[
|
||||
server-addr <server> dup "server" set [
|
||||
server-loop
|
||||
] with-disposal
|
||||
] ignore-errors ;
|
||||
|
||||
: simple-client ( -- )
|
||||
server-addr <client> [
|
||||
CHAR: b write1 flush
|
||||
number-of-requests
|
||||
[ CHAR: a dup write1 flush read1 assert= ] times
|
||||
counter get count-down
|
||||
] with-stream ;
|
||||
|
||||
: stop-server ( -- )
|
||||
server-addr <client> [
|
||||
CHAR: x write1
|
||||
] with-stream ;
|
||||
|
||||
: clients ( n -- )
|
||||
dup pprint " clients: " write [
|
||||
dup 2 * <count-down> counter set
|
||||
[ simple-server ] "Simple server" spawn drop
|
||||
yield yield
|
||||
[ [ simple-client ] "Simple client" spawn drop ] times
|
||||
counter get await
|
||||
stop-server
|
||||
yield yield
|
||||
] time ;
|
||||
|
||||
: socket-benchmarks
|
||||
10 clients
|
||||
20 clients
|
||||
40 clients ;
|
||||
! 80 clients
|
||||
! 160 clients
|
||||
! 320 clients
|
||||
! 640 clients ;
|
||||
|
||||
MAIN: socket-benchmarks
|
||||
USING: io.sockets io kernel math threads
|
||||
debugger tools.time prettyprint concurrency.count-downs
|
||||
namespaces arrays continuations ;
|
||||
IN: benchmark.sockets
|
||||
|
||||
SYMBOL: counter
|
||||
|
||||
: number-of-requests 1 ;
|
||||
|
||||
: server-addr "127.0.0.1" 7777 <inet4> ;
|
||||
|
||||
: server-loop ( server -- )
|
||||
dup accept [
|
||||
[
|
||||
read1 CHAR: x = [
|
||||
"server" get dispose
|
||||
] [
|
||||
number-of-requests
|
||||
[ read1 write1 flush ] times
|
||||
counter get count-down
|
||||
] if
|
||||
] with-stream
|
||||
] curry "Client handler" spawn drop server-loop ;
|
||||
|
||||
: simple-server ( -- )
|
||||
[
|
||||
server-addr <server> dup "server" set [
|
||||
server-loop
|
||||
] with-disposal
|
||||
] ignore-errors ;
|
||||
|
||||
: simple-client ( -- )
|
||||
server-addr <client> [
|
||||
CHAR: b write1 flush
|
||||
number-of-requests
|
||||
[ CHAR: a dup write1 flush read1 assert= ] times
|
||||
counter get count-down
|
||||
] with-stream ;
|
||||
|
||||
: stop-server ( -- )
|
||||
server-addr <client> [
|
||||
CHAR: x write1
|
||||
] with-stream ;
|
||||
|
||||
: clients ( n -- )
|
||||
dup pprint " clients: " write [
|
||||
dup 2 * <count-down> counter set
|
||||
[ simple-server ] "Simple server" spawn drop
|
||||
yield yield
|
||||
[ [ simple-client ] "Simple client" spawn drop ] times
|
||||
counter get await
|
||||
stop-server
|
||||
yield yield
|
||||
] time ;
|
||||
|
||||
: socket-benchmarks ;
|
||||
|
||||
MAIN: socket-benchmarks
|
||||
|
|
|
|||
|
|
@ -43,8 +43,6 @@ IN: builder
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
|
||||
|
||||
: make-vm ( -- desc )
|
||||
<process*>
|
||||
{ "make" } >>arguments
|
||||
|
|
@ -110,7 +108,7 @@ SYMBOL: build-status
|
|||
"Build machine: " write host-name print
|
||||
"CPU: " write cpu print
|
||||
"OS: " write os print
|
||||
"Build directory: " write cwd print nl
|
||||
"Build directory: " write cwd print
|
||||
|
||||
git-clone [ "git clone failed" print ] run-or-bail
|
||||
|
||||
|
|
@ -127,6 +125,8 @@ SYMBOL: build-status
|
|||
|
||||
"test-log" delete-file
|
||||
|
||||
"git id: " write "git-id" eval-file print nl
|
||||
|
||||
"Boot time: " write "boot-time" eval-file milli-seconds>time print
|
||||
"Load time: " write "load-time" eval-file milli-seconds>time print
|
||||
"Test time: " write "test-time" eval-file milli-seconds>time print nl
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations
|
|||
io io.files io.launcher io.sockets
|
||||
math math.parser
|
||||
combinators sequences splitting quotations arrays strings tools.time
|
||||
parser-combinators new-slots accessors assocs.lib
|
||||
sequences.deep new-slots accessors assocs.lib
|
||||
combinators.cleave bake calendar calendar.format ;
|
||||
|
||||
IN: builder.util
|
||||
|
|
@ -108,4 +108,4 @@ USE: prettyprint
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: failsafe ( quot -- ) [ drop ] recover ;
|
||||
: failsafe ( quot -- ) [ drop ] recover ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes continuations kernel math
|
||||
namespaces sequences sequences.lib tuples words strings
|
||||
tools.walker ;
|
||||
tools.walker new-slots accessors ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db
|
||||
|
|
@ -25,10 +25,10 @@ HOOK: db-close db ( handle -- )
|
|||
|
||||
: dispose-db ( db -- )
|
||||
dup db [
|
||||
dup db-insert-statements dispose-statements
|
||||
dup db-update-statements dispose-statements
|
||||
dup db-delete-statements dispose-statements
|
||||
db-handle db-close
|
||||
dup insert-statements>> dispose-statements
|
||||
dup update-statements>> dispose-statements
|
||||
dup delete-statements>> dispose-statements
|
||||
handle>> db-close
|
||||
] with-variable ;
|
||||
|
||||
TUPLE: statement handle sql in-params out-params bind-params bound? ;
|
||||
|
|
@ -36,11 +36,7 @@ TUPLE: simple-statement ;
|
|||
TUPLE: prepared-statement ;
|
||||
TUPLE: result-set sql params handle n max ;
|
||||
: <statement> ( sql in out -- statement )
|
||||
{
|
||||
set-statement-sql
|
||||
set-statement-in-params
|
||||
set-statement-out-params
|
||||
} statement construct ;
|
||||
{ (>>sql) (>>in-params) (>>out-params) } statement construct ;
|
||||
|
||||
HOOK: <simple-statement> db ( str in out -- statement )
|
||||
HOOK: <prepared-statement> db ( str in out -- statement )
|
||||
|
|
@ -62,21 +58,18 @@ GENERIC: more-rows? ( result-set -- ? )
|
|||
] if ;
|
||||
|
||||
: bind-statement ( obj statement -- )
|
||||
[ set-statement-bind-params ] keep
|
||||
swap >>bind-params
|
||||
[ bind-statement* ] keep
|
||||
t swap set-statement-bound? ;
|
||||
t >>bound? drop ;
|
||||
|
||||
: init-result-set ( result-set -- )
|
||||
dup #rows over set-result-set-max
|
||||
0 swap set-result-set-n ;
|
||||
dup #rows >>max
|
||||
0 >>n drop ;
|
||||
|
||||
: <result-set> ( query handle tuple -- result-set )
|
||||
>r >r { statement-sql statement-in-params } get-slots r>
|
||||
{
|
||||
set-result-set-sql
|
||||
set-result-set-params
|
||||
set-result-set-handle
|
||||
} result-set construct r> construct-delegate ;
|
||||
>r >r { sql>> in-params>> } get-slots r>
|
||||
{ (>>sql) (>>params) (>>handle) } result-set
|
||||
construct r> construct-delegate ;
|
||||
|
||||
: sql-row ( result-set -- seq )
|
||||
dup #columns [ row-column ] with map ;
|
||||
|
|
|
|||
|
|
@ -33,24 +33,6 @@ IN: db.postgresql.tests
|
|||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ { "John" "America" } }
|
||||
] [
|
||||
test-db [
|
||||
"select * from person where name = $1 and country = $2"
|
||||
f f <simple-statement> [
|
||||
{ { "Jane" TEXT } { "New Zealand" TEXT } }
|
||||
over do-bound-query
|
||||
|
||||
{ { "Jane" "New Zealand" } } =
|
||||
[ "test fails" throw ] unless
|
||||
|
||||
{ { "John" TEXT } { "America" TEXT } }
|
||||
swap do-bound-query
|
||||
] with-disposal
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
|
|
@ -111,244 +93,3 @@ IN: db.postgresql.tests
|
|||
|
||||
: with-dummy-db ( quot -- )
|
||||
>r T{ postgresql-db } db r> with-variable ;
|
||||
|
||||
! TEST TUPLE DB
|
||||
|
||||
TUPLE: puppy id name age ;
|
||||
: <puppy> ( name age -- puppy )
|
||||
{ set-puppy-name set-puppy-age } puppy construct ;
|
||||
|
||||
puppy "PUPPY" {
|
||||
{ "id" "ID" +native-id+ +not-null+ }
|
||||
{ "name" "NAME" { VARCHAR 256 } }
|
||||
{ "age" "AGE" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: kitty id name age ;
|
||||
: <kitty> ( name age -- kitty )
|
||||
{ set-kitty-name set-kitty-age } kitty construct ;
|
||||
|
||||
kitty "KITTY" {
|
||||
{ "id" "ID" INTEGER +assigned-id+ }
|
||||
{ "name" "NAME" TEXT }
|
||||
{ "age" "AGE" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: basket id puppies kitties ;
|
||||
basket "BASKET"
|
||||
{
|
||||
{ "id" "ID" +native-id+ +not-null+ }
|
||||
{ "location" "LOCATION" TEXT }
|
||||
{ "puppies" { +has-many+ puppy } }
|
||||
{ "kitties" { +has-many+ kitty } }
|
||||
} define-persistent
|
||||
|
||||
! Create table
|
||||
[
|
||||
"create table puppy(id serial primary key not null, name varchar 256, age integer);"
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
puppy dup db-columns swap db-table create-table-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"create table kitty(id integer primary key, name text, age integer);"
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
kitty dup db-columns swap db-table create-table-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"create table basket(id serial primary key not null, location text);"
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
basket dup db-columns swap db-table create-table-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Create function
|
||||
[
|
||||
"create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;"
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
puppy dup db-columns swap db-table create-function-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Drop table
|
||||
|
||||
[
|
||||
"drop table puppy;"
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
puppy db-table drop-table-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"drop table kitty;"
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
kitty db-table drop-table-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"drop table basket;"
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
basket db-table drop-table-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
|
||||
! Drop function
|
||||
[
|
||||
"drop function add_puppy(varchar, integer);"
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
puppy dup db-columns swap db-table drop-function-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Insert
|
||||
[
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
puppy <insert-native-statement>
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"insert into kitty(id, name, age) values($1, $2, $3);"
|
||||
{
|
||||
T{
|
||||
sql-spec
|
||||
f
|
||||
"id"
|
||||
"ID"
|
||||
INTEGER
|
||||
{ +assigned-id+ }
|
||||
+assigned-id+
|
||||
}
|
||||
T{ sql-spec f "name" "NAME" TEXT { } f }
|
||||
T{ sql-spec f "age" "AGE" INTEGER { } f }
|
||||
}
|
||||
{ }
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
kitty <insert-assigned-statement>
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Update
|
||||
[
|
||||
"update puppy set name = $1, age = $2 where id = $3"
|
||||
{
|
||||
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
|
||||
T{ sql-spec f "age" "AGE" INTEGER { } f }
|
||||
T{
|
||||
sql-spec
|
||||
f
|
||||
"id"
|
||||
"ID"
|
||||
+native-id+
|
||||
{ +not-null+ }
|
||||
+native-id+
|
||||
}
|
||||
}
|
||||
{ }
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
puppy dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"update kitty set name = $1, age = $2 where id = $3"
|
||||
{
|
||||
T{ sql-spec f "name" "NAME" TEXT { } f }
|
||||
T{ sql-spec f "age" "AGE" INTEGER { } f }
|
||||
T{
|
||||
sql-spec
|
||||
f
|
||||
"id"
|
||||
"ID"
|
||||
INTEGER
|
||||
{ +assigned-id+ }
|
||||
+assigned-id+
|
||||
}
|
||||
}
|
||||
{ }
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
kitty dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Delete
|
||||
[
|
||||
"delete from puppy where id = $1"
|
||||
{
|
||||
T{
|
||||
sql-spec
|
||||
f
|
||||
"id"
|
||||
"ID"
|
||||
+native-id+
|
||||
{ +not-null+ }
|
||||
+native-id+
|
||||
}
|
||||
}
|
||||
{ }
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
puppy dup db-columns swap db-table <delete-tuple-statement> >r >r >lower r> r>
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"delete from KITTY where ID = $1"
|
||||
{
|
||||
T{
|
||||
sql-spec
|
||||
f
|
||||
"id"
|
||||
"ID"
|
||||
INTEGER
|
||||
{ +assigned-id+ }
|
||||
+assigned-id+
|
||||
}
|
||||
}
|
||||
{ }
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
kitty dup db-columns swap db-table <delete-tuple-statement>
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Select
|
||||
[
|
||||
"select from PUPPY ID, NAME, AGE where NAME = $1;"
|
||||
{ T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } }
|
||||
{
|
||||
T{
|
||||
sql-spec
|
||||
f
|
||||
"id"
|
||||
"ID"
|
||||
+native-id+
|
||||
{ +not-null+ }
|
||||
+native-id+
|
||||
}
|
||||
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
|
||||
T{ sql-spec f "age" "AGE" INTEGER { } f }
|
||||
}
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
T{ puppy f f "Mr. Clunkers" }
|
||||
<select-by-slots-statement>
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -3,49 +3,34 @@ prettyprint tools.test db.sqlite db sequences
|
|||
continuations db.types db.tuples unicode.case ;
|
||||
IN: db.sqlite.tests
|
||||
|
||||
: test.db "extra/db/sqlite/test.db" resource-path ;
|
||||
: db-path "extra/db/sqlite/test.db" resource-path ;
|
||||
: test.db db-path sqlite-db ;
|
||||
|
||||
[ ] [ [ test.db delete-file ] ignore-errors ] unit-test
|
||||
[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
|
||||
|
||||
[ ] [
|
||||
test.db [
|
||||
"create table person (name varchar(30), country varchar(30))" sql-command
|
||||
"insert into person values('John', 'America')" sql-command
|
||||
"insert into person values('Jane', 'New Zealand')" sql-command
|
||||
] with-sqlite
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
|
||||
[ { { "John" "America" } { "Jane" "New Zealand" } } ] [
|
||||
test.db [
|
||||
"select * from person" sql-query
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[ { { "John" "America" } } ] [
|
||||
test.db [
|
||||
"select * from person where name = :name and country = :country"
|
||||
<simple-statement> [
|
||||
{ { ":name" "Jane" TEXT } { ":country" "New Zealand" TEXT } }
|
||||
over do-bound-query
|
||||
|
||||
{ { "Jane" "New Zealand" } } =
|
||||
[ "test fails" throw ] unless
|
||||
|
||||
{ { ":name" "John" TEXT } { ":country" "America" TEXT } }
|
||||
swap do-bound-query
|
||||
] with-disposal
|
||||
] with-sqlite
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ]
|
||||
[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
|
||||
[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[ ] [
|
||||
test.db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-sqlite
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -54,7 +39,7 @@ IN: db.sqlite.tests
|
|||
{ "2" "Jane" "New Zealand" }
|
||||
{ "3" "Jimmy" "Canada" }
|
||||
}
|
||||
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
|
||||
] [ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
test.db [
|
||||
|
|
@ -63,13 +48,13 @@ IN: db.sqlite.tests
|
|||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"oops" throw
|
||||
] with-transaction
|
||||
] with-sqlite
|
||||
] with-db
|
||||
] must-fail
|
||||
|
||||
[ 3 ] [
|
||||
test.db [
|
||||
"select * from person" sql-query length
|
||||
] with-sqlite
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -81,166 +66,11 @@ IN: db.sqlite.tests
|
|||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
] with-transaction
|
||||
] with-sqlite
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
test.db [
|
||||
"select * from person" sql-query length
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
! TEST TUPLE DB
|
||||
|
||||
TUPLE: puppy id name age ;
|
||||
: <puppy> ( name age -- puppy )
|
||||
{ set-puppy-name set-puppy-age } puppy construct ;
|
||||
|
||||
puppy "PUPPY" {
|
||||
{ "id" "ID" +native-id+ +not-null+ }
|
||||
{ "name" "NAME" { VARCHAR 256 } }
|
||||
{ "age" "AGE" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: kitty id name age ;
|
||||
: <kitty> ( name age -- kitty )
|
||||
{ set-kitty-name set-kitty-age } kitty construct ;
|
||||
|
||||
kitty "KITTY" {
|
||||
{ "id" "ID" INTEGER +assigned-id+ }
|
||||
{ "name" "NAME" TEXT }
|
||||
{ "age" "AGE" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: basket id puppies kitties ;
|
||||
basket "BASKET"
|
||||
{
|
||||
{ "id" "ID" +native-id+ +not-null+ }
|
||||
{ "location" "LOCATION" TEXT }
|
||||
{ "puppies" { +has-many+ puppy } }
|
||||
{ "kitties" { +has-many+ kitty } }
|
||||
} define-persistent
|
||||
|
||||
! Create table
|
||||
[
|
||||
"create table puppy(id integer primary key not null, name varchar, age integer);"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
puppy dup db-columns swap db-table create-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"create table kitty(id integer primary key, name text, age integer);"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
kitty dup db-columns swap db-table create-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"create table basket(id integer primary key not null, location text);"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
basket dup db-columns swap db-table create-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Drop table
|
||||
[
|
||||
"drop table puppy;"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
puppy db-table drop-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"drop table kitty;"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
kitty db-table drop-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"drop table basket;"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
basket db-table drop-sql >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Insert
|
||||
[
|
||||
"insert into puppy(name, age) values(:name, :age);"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
puppy dup db-columns swap db-table insert-sql* >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"insert into kitty(id, name, age) values(:id, :name, :age);"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
kitty dup db-columns swap db-table insert-sql* >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Update
|
||||
[
|
||||
"update puppy set name = :name, age = :age where id = :id"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
puppy dup db-columns swap db-table update-sql* >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"update kitty set name = :name, age = :age where id = :id"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
kitty dup db-columns swap db-table update-sql* >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Delete
|
||||
[
|
||||
"delete from puppy where id = :id"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
puppy dup db-columns swap db-table delete-sql* >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"delete from kitty where id = :id"
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
kitty dup db-columns swap db-table delete-sql* >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Select
|
||||
[
|
||||
"select from puppy id, name, age where name = :name;"
|
||||
{
|
||||
T{
|
||||
sql-spec
|
||||
f
|
||||
"id"
|
||||
"ID"
|
||||
+native-id+
|
||||
{ +not-null+ }
|
||||
+native-id+
|
||||
}
|
||||
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
|
||||
T{ sql-spec f "age" "AGE" INTEGER { } f }
|
||||
}
|
||||
] [
|
||||
T{ sqlite-db } db [
|
||||
T{ puppy f f "Mr. Clunkers" }
|
||||
select-sql >r >lower r>
|
||||
] with-variable
|
||||
] with-db
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces
|
|||
prettyprint sequences strings tuples alien.c-types
|
||||
continuations db.sqlite.lib db.sqlite.ffi db.tuples
|
||||
words combinators.lib db.types combinators tools.walker
|
||||
combinators.cleave ;
|
||||
combinators.cleave io ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db path ;
|
||||
|
|
@ -173,7 +173,9 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
|
|||
|
||||
" from " 0% 0%
|
||||
[ sql-spec-slot-name swap get-slot-named ] with subset
|
||||
dup empty? [ drop ] [
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
" where " 0%
|
||||
[ ", " 0% ]
|
||||
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
|
||||
|
|
|
|||
|
|
@ -41,73 +41,73 @@ SYMBOL: the-person2
|
|||
T{ person f 2 "johnny" 10 3.14 }
|
||||
}
|
||||
] [ T{ person f f f f 3.14 } select-tuples ] unit-test
|
||||
[
|
||||
{
|
||||
T{ person f 1 "billy" 200 3.14 }
|
||||
T{ person f 2 "johnny" 10 3.14 }
|
||||
}
|
||||
] [ T{ person f } select-tuples ] unit-test
|
||||
|
||||
|
||||
[ ] [ the-person1 get delete-tuple ] unit-test
|
||||
[ f ] [ T{ person f 1 } select-tuple ] unit-test
|
||||
[ ] [ person drop-table ] unit-test ;
|
||||
|
||||
: test-sqlite ( -- )
|
||||
"tuples-test.db" resource-path sqlite-db [
|
||||
test-tuples
|
||||
] with-db ;
|
||||
: make-native-person-table ( -- )
|
||||
[ person drop-table ] [ drop ] recover
|
||||
person create-table
|
||||
T{ person f f "billy" 200 3.14 } insert-tuple
|
||||
T{ person f f "johnny" 10 3.14 } insert-tuple
|
||||
;
|
||||
|
||||
: test-postgresql ( -- )
|
||||
{ "localhost" "postgres" "" "factor-test" } postgresql-db [
|
||||
test-tuples
|
||||
] with-db ;
|
||||
: native-person-schema ( -- )
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ID" +native-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
} define-persistent
|
||||
"billy" 10 3.14 <person> the-person1 set
|
||||
"johnny" 10 3.14 <person> the-person2 set ;
|
||||
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ID" +native-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
} define-persistent
|
||||
: assigned-person-schema ( -- )
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ID" INTEGER +assigned-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
} define-persistent
|
||||
1 "billy" 10 3.14 <assigned-person> the-person1 set
|
||||
2 "johnny" 10 3.14 <assigned-person> the-person2 set ;
|
||||
|
||||
"billy" 10 3.14 <person> the-person1 set
|
||||
"johnny" 10 3.14 <person> the-person2 set
|
||||
|
||||
test-sqlite
|
||||
! test-postgresql
|
||||
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ID" INTEGER +assigned-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
} define-persistent
|
||||
|
||||
1 "billy" 10 3.14 <assigned-person> the-person1 set
|
||||
2 "johnny" 10 3.14 <assigned-person> the-person2 set
|
||||
|
||||
test-sqlite
|
||||
! test-postgresql
|
||||
|
||||
TUPLE: paste n summary author channel mode contents timestamp annotations ;
|
||||
TUPLE: annotation n paste-id summary author mode contents ;
|
||||
|
||||
paste "PASTE"
|
||||
{
|
||||
{ "n" "ID" +native-id+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "channel" "CHANNEL" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
{ "date" "DATE" TIMESTAMP }
|
||||
{ "annotations" { +has-many+ annotation } }
|
||||
} define-persistent
|
||||
: native-paste-schema ( -- )
|
||||
paste "PASTE"
|
||||
{
|
||||
{ "n" "ID" +native-id+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "channel" "CHANNEL" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
{ "date" "DATE" TIMESTAMP }
|
||||
{ "annotations" { +has-many+ annotation } }
|
||||
} define-persistent
|
||||
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +native-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +native-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent ;
|
||||
|
||||
! { "localhost" "postgres" "" "factor-test" } postgresql-db [
|
||||
! [ paste drop-table ] [ drop ] recover
|
||||
|
|
@ -117,3 +117,15 @@ annotation "ANNOTATION"
|
|||
! [ ] [ paste create-table ] unit-test
|
||||
! [ ] [ annotation create-table ] unit-test
|
||||
! ] with-db
|
||||
|
||||
|
||||
: test-sqlite ( quot -- )
|
||||
>r "tuples-test.db" resource-path sqlite-db r> with-db ;
|
||||
|
||||
: test-postgresql ( -- )
|
||||
>r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
|
||||
|
||||
[ native-person-schema test-tuples ] test-sqlite
|
||||
[ assigned-person-schema test-tuples ] test-sqlite
|
||||
|
||||
! [ make-native-person-table ] test-sqlite
|
||||
|
|
|
|||
|
|
@ -1,42 +1,44 @@
|
|||
USING: farkup kernel tools.test ;
|
||||
IN: farkup.tests
|
||||
|
||||
[ "<ul><li>foo</li></ul>" ] [ "-foo" parse-farkup ] unit-test
|
||||
[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" parse-farkup ] unit-test
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" parse-farkup ] unit-test
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" parse-farkup ] unit-test
|
||||
[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" parse-farkup ] unit-test
|
||||
[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" parse-farkup ] unit-test
|
||||
[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" parse-farkup ] unit-test
|
||||
[ "<p><em>Wow.</em></p>" ] [ "_Wow._" parse-farkup ] unit-test
|
||||
[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
|
||||
[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
|
||||
[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
|
||||
[ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>*</p>" ] [ "*" parse-farkup ] unit-test
|
||||
[ "<p>*</p>" ] [ "\\*" parse-farkup ] unit-test
|
||||
[ "<p>**</p>" ] [ "\\**" parse-farkup ] unit-test
|
||||
[ "<p>*</p>" ] [ "*" convert-farkup ] unit-test
|
||||
[ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
|
||||
[ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
|
||||
|
||||
[ "" ] [ "\n\n" parse-farkup ] unit-test
|
||||
[ "\n" ] [ "\n\n\n" parse-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" parse-farkup ] unit-test
|
||||
[ "" ] [ "\n\n" convert-farkup ] unit-test
|
||||
[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
|
||||
|
||||
[ "\n<p>bar\n</p>" ] [ "\nbar\n" parse-farkup ] unit-test
|
||||
[ "\n<p>bar\n</p>" ] [ "\nbar\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" parse-farkup ] unit-test
|
||||
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
|
||||
|
||||
[ "" ] [ "" parse-farkup ] unit-test
|
||||
[ "" ] [ "" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>|a</p>" ]
|
||||
[ "|a" parse-farkup ] unit-test
|
||||
[ "|a" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>|a|</p>" ]
|
||||
[ "|a|" parse-farkup ] unit-test
|
||||
[ "|a|" convert-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>" ]
|
||||
[ "a|b" parse-farkup ] unit-test
|
||||
[ "a|b" convert-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>" ]
|
||||
[ "a|b\nc|d" parse-farkup ] unit-test
|
||||
[ "a|b\nc|d" convert-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>\n" ]
|
||||
[ "a|b\nc|d\n" parse-farkup ] unit-test
|
||||
[ "a|b\nc|d\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
|
||||
[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,24 +1,20 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays io kernel memoize namespaces peg
|
||||
peg.ebnf sequences strings html.elements xml.entities
|
||||
xmode.code2html splitting io.streams.string html
|
||||
html.elements sequences.deep ascii ;
|
||||
! unicode.categories ;
|
||||
USE: tools.walker
|
||||
USING: arrays io kernel memoize namespaces peg sequences strings
|
||||
html.elements xml.entities xmode.code2html splitting
|
||||
io.streams.string html peg.parsers html.elements sequences.deep
|
||||
unicode.categories ;
|
||||
IN: farkup
|
||||
|
||||
MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
|
||||
|
||||
: delimiters ( -- string )
|
||||
"*_^~%=[-|\\\n" ; inline
|
||||
"*_^~%[-=|\\\n" ; inline
|
||||
|
||||
MEMO: text ( -- parser )
|
||||
[ delimiters member? not ] satisfy repeat1
|
||||
[ >string escape-string ] action ;
|
||||
|
||||
MEMO: delimiter ( -- parser )
|
||||
[ dup delimiters member? swap CHAR: \n = not and ] satisfy
|
||||
[ dup delimiters member? swap "\n=" member? not and ] satisfy
|
||||
[ 1string ] action ;
|
||||
|
||||
: surround-with-foo ( string tag -- seq )
|
||||
|
|
@ -39,12 +35,12 @@ MEMO: emphasis ( -- parser ) "_" "em" delimited ;
|
|||
MEMO: superscript ( -- parser ) "^" "sup" delimited ;
|
||||
MEMO: subscript ( -- parser ) "~" "sub" delimited ;
|
||||
MEMO: inline-code ( -- parser ) "%" "code" delimited ;
|
||||
MEMO: nl ( -- parser ) "\n" token ;
|
||||
MEMO: 2nl ( -- parser ) "\n\n" token hide ;
|
||||
MEMO: h1 ( -- parser ) "=" "h1" delimited ;
|
||||
MEMO: h2 ( -- parser ) "==" "h2" delimited ;
|
||||
MEMO: h3 ( -- parser ) "===" "h3" delimited ;
|
||||
MEMO: h4 ( -- parser ) "====" "h4" delimited ;
|
||||
MEMO: nl ( -- parser ) "\n" token ;
|
||||
MEMO: 2nl ( -- parser ) "\n\n" token hide ;
|
||||
|
||||
: render-code ( string mode -- string' )
|
||||
>r string-lines r>
|
||||
|
|
@ -87,7 +83,7 @@ MEMO: table-column ( -- parser )
|
|||
|
||||
MEMO: table-row ( -- parser )
|
||||
[
|
||||
table-column "|" token hide list-of* ,
|
||||
table-column "|" token hide list-of-many ,
|
||||
] seq* [ "tr" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table ( -- parser )
|
||||
|
|
@ -121,28 +117,13 @@ MEMO: paragraph ( -- parser )
|
|||
[ "<p>" swap "</p>" 3array ] unless
|
||||
] action ;
|
||||
|
||||
MEMO: farkup ( -- parser )
|
||||
PEG: parse-farkup ( -- parser )
|
||||
[
|
||||
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
|
||||
] choice* repeat0 "\n" token optional 2seq ;
|
||||
|
||||
: farkup. ( parse-result -- )
|
||||
parse-result-ast
|
||||
: write-farkup ( parse-result -- )
|
||||
[ dup string? [ write ] [ drop ] if ] deep-each ;
|
||||
|
||||
: parse-farkup ( string -- string' )
|
||||
farkup parse [ farkup. ] with-string-writer ;
|
||||
|
||||
! MEMO: table-column ( -- parser )
|
||||
! text [ "td" surround-with-foo ] action ;
|
||||
!
|
||||
! MEMO: table-row ( -- parser )
|
||||
! [
|
||||
! "|" token hide ,
|
||||
! table-column "|" token hide list-of ,
|
||||
! "|" token "\n" token 2array choice hide ,
|
||||
! ] seq* [ "tr" surround-with-foo ] action ;
|
||||
!
|
||||
! MEMO: table ( -- parser )
|
||||
! table-row repeat1
|
||||
! [ "table" surround-with-foo ] action ;
|
||||
: convert-farkup ( string -- string' )
|
||||
parse-farkup [ write-farkup ] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel peg strings promises sequences math math.parser
|
||||
namespaces words quotations arrays hashtables io
|
||||
io.streams.string assocs memoize ascii ;
|
||||
io.streams.string assocs memoize ascii peg.parsers ;
|
||||
IN: fjsc
|
||||
|
||||
TUPLE: ast-number value ;
|
||||
|
|
|
|||
|
|
@ -1,42 +1,46 @@
|
|||
IN: fry.tests
|
||||
USING: fry tools.test math prettyprint kernel io arrays
|
||||
sequences ;
|
||||
|
||||
[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
|
||||
|
||||
[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
|
||||
|
||||
[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
|
||||
|
||||
[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
|
||||
|
||||
[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
|
||||
|
||||
[ [ "a" write "b" print ] ]
|
||||
[ "a" "b" '[ , write , print ] ] unit-test
|
||||
|
||||
[ [ 1 2 + 3 4 - ] ]
|
||||
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
|
||||
|
||||
[ 1/2 ] [
|
||||
1 '[ , _ / ] 2 swap call
|
||||
] unit-test
|
||||
|
||||
[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
|
||||
1 '[ , _ _ 3array ]
|
||||
{ "a" "b" "c" } { "A" "B" "C" } rot 2map
|
||||
] unit-test
|
||||
|
||||
[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
|
||||
'[ 1 _ 2array ]
|
||||
{ "a" "b" "c" } swap map
|
||||
] unit-test
|
||||
|
||||
[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
|
||||
1 2 '[ , _ , 3array ]
|
||||
{ "a" "b" "c" } swap map
|
||||
] unit-test
|
||||
|
||||
: funny-dip '[ @ _ ] call ; inline
|
||||
|
||||
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
|
||||
IN: fry.tests
|
||||
USING: fry tools.test math prettyprint kernel io arrays
|
||||
sequences ;
|
||||
|
||||
[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
|
||||
|
||||
[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
|
||||
|
||||
[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
|
||||
|
||||
[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
|
||||
|
||||
[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
|
||||
|
||||
[ [ "a" write "b" print ] ]
|
||||
[ "a" "b" '[ , write , print ] ] unit-test
|
||||
|
||||
[ [ 1 2 + 3 4 - ] ]
|
||||
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
|
||||
|
||||
[ 1/2 ] [
|
||||
1 '[ , _ / ] 2 swap call
|
||||
] unit-test
|
||||
|
||||
[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
|
||||
1 '[ , _ _ 3array ]
|
||||
{ "a" "b" "c" } { "A" "B" "C" } rot 2map
|
||||
] unit-test
|
||||
|
||||
[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
|
||||
'[ 1 _ 2array ]
|
||||
{ "a" "b" "c" } swap map
|
||||
] unit-test
|
||||
|
||||
[ 1 2 ] [
|
||||
1 2 '[ _ , ] call
|
||||
] unit-test
|
||||
|
||||
[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
|
||||
1 2 '[ , _ , 3array ]
|
||||
{ "a" "b" "c" } swap map
|
||||
] unit-test
|
||||
|
||||
: funny-dip '[ @ _ ] call ; inline
|
||||
|
||||
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,39 +1,44 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences combinators parser splitting
|
||||
quotations ;
|
||||
IN: fry
|
||||
|
||||
: , "Only valid inside a fry" throw ;
|
||||
: @ "Only valid inside a fry" throw ;
|
||||
: _ "Only valid inside a fry" throw ;
|
||||
|
||||
DEFER: (fry)
|
||||
|
||||
: ((fry)) ( accum quot adder -- result )
|
||||
>r [ ] swap (fry) r>
|
||||
append swap dup empty? [ drop ] [
|
||||
[ swap compose ] curry append
|
||||
] if ; inline
|
||||
|
||||
: (fry) ( accum quot -- result )
|
||||
dup empty? [
|
||||
drop 1quotation
|
||||
] [
|
||||
unclip {
|
||||
{ , [ [ curry ] ((fry)) ] }
|
||||
{ @ [ [ compose ] ((fry)) ] }
|
||||
[ swap >r add r> (fry) ]
|
||||
} case
|
||||
] if ;
|
||||
|
||||
: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
|
||||
|
||||
: fry ( quot -- quot' )
|
||||
{ _ } last-split1 [
|
||||
>r fry [ [ dip ] curry ] r> trivial-fry [ compose ] compose 3compose
|
||||
] [
|
||||
trivial-fry
|
||||
] if* ;
|
||||
|
||||
: '[ \ ] parse-until fry over push-all ; parsing
|
||||
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences combinators parser splitting
|
||||
quotations arrays namespaces ;
|
||||
IN: fry
|
||||
|
||||
: , "Only valid inside a fry" throw ;
|
||||
: @ "Only valid inside a fry" throw ;
|
||||
: _ "Only valid inside a fry" throw ;
|
||||
|
||||
DEFER: (fry)
|
||||
|
||||
: ((fry)) ( accum quot adder -- result )
|
||||
>r [ ] swap (fry) r>
|
||||
append swap dup empty? [ drop ] [
|
||||
[ swap compose ] curry append
|
||||
] if ; inline
|
||||
|
||||
: (fry) ( accum quot -- result )
|
||||
dup empty? [
|
||||
drop 1quotation
|
||||
] [
|
||||
unclip {
|
||||
{ , [ [ curry ] ((fry)) ] }
|
||||
{ @ [ [ compose ] ((fry)) ] }
|
||||
[ swap >r add r> (fry) ]
|
||||
} case
|
||||
] if ;
|
||||
|
||||
: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
|
||||
|
||||
: fry ( quot -- quot' )
|
||||
{ _ } last-split1 [
|
||||
[
|
||||
trivial-fry %
|
||||
[ >r ] %
|
||||
fry %
|
||||
[ [ dip ] curry r> compose ] %
|
||||
] [ ] make
|
||||
] [
|
||||
trivial-fry
|
||||
] if* ;
|
||||
|
||||
: '[ \ ] parse-until fry over push-all ; parsing
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ TUPLE: test-tuple m n ;
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"/responder/temporary/foo?foo=3"
|
||||
"/responder/furnace.tests/foo?foo=3"
|
||||
] [
|
||||
[
|
||||
[ "3" foo ] quot-link
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: help.definitions.tests
|
|||
[ t ] [ "hello" articles get key? ] unit-test
|
||||
[ t ] [ "hello2" articles get key? ] unit-test
|
||||
[ t ] [
|
||||
"hello" "help.definitions" lookup "help" word-prop >boolean
|
||||
"hello" "help.definitions.tests" lookup "help" word-prop >boolean
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [
|
||||
|
|
@ -29,12 +29,12 @@ IN: help.definitions.tests
|
|||
[ t ] [ "hello" articles get key? ] unit-test
|
||||
[ f ] [ "hello2" articles get key? ] unit-test
|
||||
[ f ] [
|
||||
"hello" "help.definitions" lookup "help" word-prop
|
||||
"hello" "help.definitions.tests" lookup "help" word-prop
|
||||
] unit-test
|
||||
|
||||
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
|
||||
|
||||
[ ] [ "xxx" "help.definitions" lookup help ] unit-test
|
||||
[ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test
|
||||
|
||||
[ ] [ "xxx" "help.definitions" lookup >link synopsis print ] unit-test
|
||||
[ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test
|
||||
] with-file-vocabs
|
||||
|
|
|
|||
|
|
@ -144,20 +144,32 @@ M: f print-element drop ;
|
|||
: $link ( element -- )
|
||||
first ($link) ;
|
||||
|
||||
: ($subsection) ( object -- )
|
||||
[ article-title ] keep >link write-object ;
|
||||
: ($long-link) ( object -- )
|
||||
dup article-title swap >link write-link ;
|
||||
|
||||
: $subsection ( element -- )
|
||||
: ($subsection) ( element quot -- )
|
||||
[
|
||||
subsection-style get [
|
||||
bullet get write bl
|
||||
first ($subsection)
|
||||
call
|
||||
] with-style
|
||||
] ($block) ;
|
||||
] ($block) ; inline
|
||||
|
||||
: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ;
|
||||
: $subsection ( element -- )
|
||||
[ first ($long-link) ] ($subsection) ;
|
||||
|
||||
: $vocab-link ( element -- ) first ($vocab-link) ;
|
||||
: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
|
||||
|
||||
: $vocab-subsection ( element -- )
|
||||
[
|
||||
first2 dup vocab-help dup [
|
||||
2nip ($long-link)
|
||||
] [
|
||||
drop ($vocab-link)
|
||||
] if
|
||||
] ($subsection) ;
|
||||
|
||||
: $vocab-link ( element -- ) first dup ($vocab-link) ;
|
||||
|
||||
: $vocabulary ( element -- )
|
||||
first word-vocabulary [
|
||||
|
|
|
|||
|
|
@ -4,18 +4,18 @@ USING: tools.test parser vocabs help.syntax namespaces ;
|
|||
[
|
||||
[ "foobar" ] [
|
||||
"IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval
|
||||
"help.syntax" vocab vocab-help
|
||||
"help.syntax.tests" vocab vocab-help
|
||||
] unit-test
|
||||
|
||||
[ { "foobar" } ] [
|
||||
"IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval
|
||||
"help.syntax" vocab vocab-help
|
||||
"help.syntax.tests" vocab vocab-help
|
||||
] unit-test
|
||||
|
||||
SYMBOL: xyz
|
||||
|
||||
[ xyz ] [
|
||||
"IN: help.syntax.tests USE: help.syntax ABOUT: xyz" eval
|
||||
"help.syntax" vocab vocab-help
|
||||
"help.syntax.tests" vocab vocab-help
|
||||
] unit-test
|
||||
] with-file-vocabs
|
||||
|
|
|
|||
|
|
@ -1,5 +0,0 @@
|
|||
USING: io.backend ;
|
||||
IN: io.files.temporary.backend
|
||||
|
||||
HOOK: (temporary-file) io-backend ( path -- stream path )
|
||||
HOOK: temporary-path io-backend ( -- path )
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
USING: kernel math math.bitfields combinators.lib math.parser
|
||||
random sequences sequences.lib continuations namespaces
|
||||
io.files io.backend io.nonblocking io arrays
|
||||
io.files.temporary.backend system combinators vocabs.loader ;
|
||||
IN: io.files.temporary
|
||||
|
||||
: random-letter ( -- ch ) 26 random { CHAR: a CHAR: A } random + ;
|
||||
|
||||
: random-ch ( -- ch )
|
||||
{ t f } random [ 10 random CHAR: 0 + ] [ random-letter ] if ;
|
||||
|
||||
: random-name ( n -- string ) [ drop random-ch ] "" map-as ;
|
||||
|
||||
: <temporary-file> ( prefix suffix -- path duplex-stream )
|
||||
temporary-path -rot
|
||||
[ 10 random-name swap 3append path+ dup (temporary-file) ] 3curry
|
||||
10 retry ;
|
||||
|
||||
: with-temporary-file ( quot -- path )
|
||||
>r f f <temporary-file> r> with-stream ;
|
||||
|
||||
: temporary-directory ( -- path )
|
||||
[ temporary-path 10 random-name path+ dup make-directory ] 10 retry ;
|
||||
|
||||
: with-temporary-directory ( quot -- )
|
||||
>r temporary-directory r>
|
||||
[ with-directory ] 2keep drop delete-tree ;
|
||||
|
||||
{
|
||||
{ [ unix? ] [ "io.unix.files.temporary" ] }
|
||||
{ [ windows? ] [ "io.windows.files.temporary" ] }
|
||||
} cond require
|
||||
|
|
@ -35,33 +35,43 @@ HELP: +environment-mode+
|
|||
HELP: +stdin+
|
||||
{ $description "Launch descriptor key. Must equal one of the following:"
|
||||
{ $list
|
||||
{ { $link f } " - standard input is inherited" }
|
||||
{ { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
|
||||
{ { $link +inherit+ } " - standard input is inherited from the current process" }
|
||||
{ { $link +closed+ } " - standard input is closed" }
|
||||
{ "a path name - standard input is read from the given file, which must exist" }
|
||||
{ "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +stdout+
|
||||
{ $description "Launch descriptor key. Must equal one of the following:"
|
||||
{ $list
|
||||
{ { $link f } " - standard output is inherited" }
|
||||
{ { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
|
||||
{ { $link +inherit+ } " - standard output is inherited from the current process" }
|
||||
{ { $link +closed+ } " - standard output is closed" }
|
||||
{ "a path name - standard output is written to the given file, which is overwritten if it already exists" }
|
||||
{ "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +stderr+
|
||||
{ $description "Launch descriptor key. Must equal one of the following:"
|
||||
{ $list
|
||||
{ { $link f } " - standard error is inherited" }
|
||||
{ { $link f } " - standard error is inherited from the current process" }
|
||||
{ { $link +inherit+ } " - same as above" }
|
||||
{ { $link +stdout+ } " - standard error is merged with standard output" }
|
||||
{ { $link +closed+ } " - standard error is closed" }
|
||||
{ "a path name - standard error is written to the given file, which is overwritten if it already exists" }
|
||||
{ "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +closed+
|
||||
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
|
||||
|
||||
HELP: +inherit+
|
||||
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
|
||||
|
||||
HELP: +prepend-environment+
|
||||
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.backend io.timeouts system kernel namespaces
|
||||
strings hashtables sequences assocs combinators vocabs.loader
|
||||
init threads continuations math ;
|
||||
USING: io io.backend io.nonblocking io.streams.duplex
|
||||
io.timeouts system kernel namespaces strings hashtables
|
||||
sequences assocs combinators vocabs.loader init threads
|
||||
continuations math ;
|
||||
IN: io.launcher
|
||||
|
||||
! Non-blocking process exit notification facility
|
||||
|
|
@ -35,13 +36,16 @@ SYMBOL: +environment-mode+
|
|||
SYMBOL: +stdin+
|
||||
SYMBOL: +stdout+
|
||||
SYMBOL: +stderr+
|
||||
SYMBOL: +closed+
|
||||
|
||||
SYMBOL: +timeout+
|
||||
|
||||
SYMBOL: +prepend-environment+
|
||||
SYMBOL: +replace-environment+
|
||||
SYMBOL: +append-environment+
|
||||
|
||||
SYMBOL: +closed+
|
||||
SYMBOL: +inherit+
|
||||
|
||||
: default-descriptor
|
||||
H{
|
||||
{ +command+ f }
|
||||
|
|
@ -141,3 +145,12 @@ TUPLE: process-stream process ;
|
|||
[ set-process-status ] keep
|
||||
[ processes get delete-at* drop [ resume ] each ] keep
|
||||
f swap set-process-handle ;
|
||||
|
||||
GENERIC: underlying-handle ( stream -- handle )
|
||||
|
||||
M: port underlying-handle port-handle ;
|
||||
|
||||
M: duplex-stream underlying-handle
|
||||
dup duplex-stream-in underlying-handle
|
||||
swap duplex-stream-out underlying-handle tuck =
|
||||
[ "Invalid duplex stream" throw ] when ;
|
||||
|
|
|
|||
|
|
@ -1,33 +1,80 @@
|
|||
IN: io.unix.launcher.tests
|
||||
USING: io.unix.launcher tools.test ;
|
||||
USING: io.files tools.test io.launcher arrays io namespaces
|
||||
continuations math ;
|
||||
|
||||
[ "" tokenize-command ] must-fail
|
||||
[ " " tokenize-command ] must-fail
|
||||
[ { "a" } ] [ "a" tokenize-command ] unit-test
|
||||
[ { "abc" } ] [ "abc" tokenize-command ] unit-test
|
||||
[ { "abc" } ] [ "abc " tokenize-command ] unit-test
|
||||
[ { "abc" } ] [ " abc" tokenize-command ] unit-test
|
||||
[ { "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
|
||||
[ { "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
|
||||
[ { "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
|
||||
[ { "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
|
||||
[ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
|
||||
[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
|
||||
[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
|
||||
[ "'abc def' \"hey" tokenize-command ] must-fail
|
||||
[ "'abc def" tokenize-command ] must-fail
|
||||
[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
"Hello world.app/Contents/MacOS/hello-ui"
|
||||
"-i=boot.macosx-ppc.image"
|
||||
"-include= math compiler ui"
|
||||
"-deploy-vocab=hello-ui"
|
||||
"-output-image=Hello world.app/Contents/Resources/hello-ui.image"
|
||||
"-no-stack-traces"
|
||||
"-no-user-init"
|
||||
}
|
||||
] [
|
||||
"\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
|
||||
[ ] [
|
||||
[ "launcher-test-1" temp-file delete-file ] ignore-errors
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"touch"
|
||||
"launcher-test-1" temp-file
|
||||
2array
|
||||
try-process
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "launcher-test-1" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [
|
||||
[ "launcher-test-1" temp-file delete-file ] ignore-errors
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"echo Hello" +command+ set
|
||||
"launcher-test-1" temp-file +stdout+ set
|
||||
] { } make-assoc try-process
|
||||
] unit-test
|
||||
|
||||
[ "Hello\n" ] [
|
||||
"cat"
|
||||
"launcher-test-1" temp-file
|
||||
2array
|
||||
<process-stream> contents
|
||||
] unit-test
|
||||
|
||||
[ "" ] [
|
||||
[
|
||||
"cat"
|
||||
"launcher-test-1" temp-file
|
||||
2array +arguments+ set
|
||||
+inherit+ +stdout+ set
|
||||
] { } make-assoc <process-stream> contents
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ "launcher-test-1" temp-file delete-file ] ignore-errors
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"cat" +command+ set
|
||||
+closed+ +stdin+ set
|
||||
"launcher-test-1" temp-file +stdout+ set
|
||||
] { } make-assoc try-process
|
||||
] unit-test
|
||||
|
||||
[ "" ] [
|
||||
"cat"
|
||||
"launcher-test-1" temp-file
|
||||
2array
|
||||
<process-stream> contents
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
2 [
|
||||
"launcher-test-1" temp-file <file-appender> [
|
||||
[
|
||||
+stdout+ set
|
||||
"echo Hello" +command+ set
|
||||
] { } make-assoc try-process
|
||||
] with-disposal
|
||||
] times
|
||||
] unit-test
|
||||
|
||||
[ "Hello\nHello\n" ] [
|
||||
"cat"
|
||||
"launcher-test-1" temp-file
|
||||
2array
|
||||
<process-stream> contents
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,56 +1,45 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.backend io.launcher io.unix.backend io.unix.files
|
||||
io.nonblocking sequences kernel namespaces math system
|
||||
alien.c-types debugger continuations arrays assocs
|
||||
combinators unix.process parser-combinators memoize
|
||||
promises strings threads unix ;
|
||||
USING: io io.backend io.launcher io.nonblocking io.unix.backend
|
||||
io.unix.files io.nonblocking sequences kernel namespaces math
|
||||
system alien.c-types debugger continuations arrays assocs
|
||||
combinators unix.process strings threads unix
|
||||
io.unix.launcher.parser ;
|
||||
IN: io.unix.launcher
|
||||
|
||||
! Search unix first
|
||||
USE: unix
|
||||
|
||||
! Our command line parser. Supported syntax:
|
||||
! foo bar baz -- simple tokens
|
||||
! foo\ bar -- escaping the space
|
||||
! 'foo bar' -- quotation
|
||||
! "foo bar" -- quotation
|
||||
LAZY: 'escaped-char' "\\" token any-char-parser &> ;
|
||||
|
||||
LAZY: 'quoted-char' ( delimiter -- parser' )
|
||||
'escaped-char'
|
||||
swap [ member? not ] curry satisfy
|
||||
<|> ; inline
|
||||
|
||||
LAZY: 'quoted' ( delimiter -- parser )
|
||||
dup 'quoted-char' <!*> swap dup surrounded-by ;
|
||||
|
||||
LAZY: 'unquoted' ( -- parser ) " '\"" 'quoted-char' <!+> ;
|
||||
|
||||
LAZY: 'argument' ( -- parser )
|
||||
"\"" 'quoted' "'" 'quoted' 'unquoted' <|> <|>
|
||||
[ >string ] <@ ;
|
||||
|
||||
MEMO: 'arguments' ( -- parser )
|
||||
'argument' " " token <!+> nonempty-list-of ;
|
||||
|
||||
: tokenize-command ( command -- arguments )
|
||||
'arguments' just parse-1 ;
|
||||
|
||||
: get-arguments ( -- seq )
|
||||
+command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
|
||||
|
||||
: assoc>env ( assoc -- env )
|
||||
[ "=" swap 3append ] { } assoc>map ;
|
||||
|
||||
: (redirect) ( path mode fd -- )
|
||||
>r file-mode open dup io-error dup
|
||||
r> dup2 io-error close ;
|
||||
: redirect-fd ( oldfd fd -- )
|
||||
2dup = [ 2drop ] [ dupd dup2 io-error close ] if ;
|
||||
|
||||
: reset-fd ( fd -- ) F_SETFL 0 fcntl io-error ;
|
||||
|
||||
: redirect-inherit ( obj mode fd -- )
|
||||
2nip reset-fd ;
|
||||
|
||||
: redirect-file ( obj mode fd -- )
|
||||
>r file-mode open dup io-error r> redirect-fd ;
|
||||
|
||||
: redirect-closed ( obj mode fd -- )
|
||||
>r >r drop "/dev/null" r> r> redirect-file ;
|
||||
|
||||
: redirect-stream ( obj mode fd -- )
|
||||
>r drop underlying-handle dup reset-fd r> redirect-fd ;
|
||||
|
||||
: redirect ( obj mode fd -- )
|
||||
{
|
||||
{ [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
|
||||
{ [ pick string? ] [ (redirect) ] }
|
||||
{ [ pick not ] [ redirect-inherit ] }
|
||||
{ [ pick string? ] [ redirect-file ] }
|
||||
{ [ pick +closed+ eq? ] [ redirect-closed ] }
|
||||
{ [ pick +inherit+ eq? ] [ redirect-closed ] }
|
||||
{ [ t ] [ redirect-stream ] }
|
||||
} cond ;
|
||||
|
||||
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,33 @@
|
|||
IN: io.unix.launcher.parser.tests
|
||||
USING: io.unix.launcher.parser tools.test ;
|
||||
|
||||
[ "" tokenize-command ] must-fail
|
||||
[ " " tokenize-command ] must-fail
|
||||
[ V{ "a" } ] [ "a" tokenize-command ] unit-test
|
||||
[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test
|
||||
[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test
|
||||
[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test
|
||||
[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
|
||||
[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
|
||||
[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
|
||||
[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
|
||||
[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
|
||||
[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
|
||||
[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
|
||||
[ "'abc def' \"hey" tokenize-command ] must-fail
|
||||
[ "'abc def" tokenize-command ] must-fail
|
||||
[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
"Hello world.app/Contents/MacOS/hello-ui"
|
||||
"-i=boot.macosx-ppc.image"
|
||||
"-include= math compiler ui"
|
||||
"-deploy-vocab=hello-ui"
|
||||
"-output-image=Hello world.app/Contents/Resources/hello-ui.image"
|
||||
"-no-stack-traces"
|
||||
"-no-user-init"
|
||||
}
|
||||
] [
|
||||
"\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: peg peg.parsers kernel sequences strings words
|
||||
memoize ;
|
||||
IN: io.unix.launcher.parser
|
||||
|
||||
! Our command line parser. Supported syntax:
|
||||
! foo bar baz -- simple tokens
|
||||
! foo\ bar -- escaping the space
|
||||
! 'foo bar' -- quotation
|
||||
! "foo bar" -- quotation
|
||||
MEMO: 'escaped-char' ( -- parser )
|
||||
"\\" token [ drop t ] satisfy 2seq [ second ] action ;
|
||||
|
||||
MEMO: 'quoted-char' ( delimiter -- parser' )
|
||||
'escaped-char'
|
||||
swap [ member? not ] curry satisfy
|
||||
2choice ; inline
|
||||
|
||||
MEMO: 'quoted' ( delimiter -- parser )
|
||||
dup 'quoted-char' repeat0 swap dup surrounded-by ;
|
||||
|
||||
MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
|
||||
|
||||
MEMO: 'argument' ( -- parser )
|
||||
"\"" 'quoted'
|
||||
"'" 'quoted'
|
||||
'unquoted' 3choice
|
||||
[ >string ] action ;
|
||||
|
||||
PEG: tokenize-command ( command -- ast/f )
|
||||
'argument' " " token repeat1 list-of
|
||||
" " token repeat0 swap over pack
|
||||
just ;
|
||||
|
|
@ -0,0 +1,108 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types io.files io.windows kernel
|
||||
math windows windows.kernel32 combinators.cleave
|
||||
windows.time calendar combinators math.functions
|
||||
sequences combinators.lib namespaces words ;
|
||||
IN: io.windows.files
|
||||
|
||||
SYMBOL: +read-only+
|
||||
SYMBOL: +hidden+
|
||||
SYMBOL: +system+
|
||||
SYMBOL: +directory+
|
||||
SYMBOL: +archive+
|
||||
SYMBOL: +device+
|
||||
SYMBOL: +normal+
|
||||
SYMBOL: +temporary+
|
||||
SYMBOL: +sparse-file+
|
||||
SYMBOL: +reparse-point+
|
||||
SYMBOL: +compressed+
|
||||
SYMBOL: +offline+
|
||||
SYMBOL: +not-content-indexed+
|
||||
SYMBOL: +encrypted+
|
||||
|
||||
: expand-constants ( word/obj -- obj'/obj )
|
||||
dup word? [ execute ] when ;
|
||||
|
||||
: get-flags ( n seq -- seq' )
|
||||
[
|
||||
[
|
||||
first2 expand-constants
|
||||
[ swapd mask? [ , ] [ drop ] if ] 2curry
|
||||
] map call-with
|
||||
] { } make ;
|
||||
|
||||
: win32-file-attributes ( n -- seq )
|
||||
{
|
||||
{ +read-only+ FILE_ATTRIBUTE_READONLY }
|
||||
{ +hidden+ FILE_ATTRIBUTE_HIDDEN }
|
||||
{ +system+ FILE_ATTRIBUTE_SYSTEM }
|
||||
{ +directory+ FILE_ATTRIBUTE_DIRECTORY }
|
||||
{ +archive+ FILE_ATTRIBUTE_ARCHIVE }
|
||||
{ +device+ FILE_ATTRIBUTE_DEVICE }
|
||||
{ +normal+ FILE_ATTRIBUTE_NORMAL }
|
||||
{ +temporary+ FILE_ATTRIBUTE_TEMPORARY }
|
||||
{ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE }
|
||||
{ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT }
|
||||
{ +compressed+ FILE_ATTRIBUTE_COMPRESSED }
|
||||
{ +offline+ FILE_ATTRIBUTE_OFFLINE }
|
||||
{ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED }
|
||||
{ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED }
|
||||
} get-flags ;
|
||||
|
||||
: WIN32_FIND_DATA>file-info
|
||||
{
|
||||
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
|
||||
[
|
||||
[ WIN32_FIND_DATA-nFileSizeLow ]
|
||||
[ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
|
||||
]
|
||||
[ WIN32_FIND_DATA-dwFileAttributes ]
|
||||
[
|
||||
WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp
|
||||
]
|
||||
} cleave
|
||||
\ file-info construct-boa ;
|
||||
|
||||
: find-first-file-stat ( path -- WIN32_FIND_DATA )
|
||||
"WIN32_FIND_DATA" <c-object> [
|
||||
FindFirstFile
|
||||
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
|
||||
FindClose win32-error=0/f
|
||||
] keep ;
|
||||
|
||||
: BY_HANDLE_FILE_INFORMATION>file-info
|
||||
{
|
||||
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes ]
|
||||
[
|
||||
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
|
||||
[ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
|
||||
]
|
||||
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ]
|
||||
[
|
||||
BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
|
||||
FILETIME>timestamp
|
||||
]
|
||||
} cleave
|
||||
\ file-info construct-boa ;
|
||||
|
||||
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
|
||||
[
|
||||
"BY_HANDLE_FILE_INFORMATION" <c-object>
|
||||
[ GetFileInformationByHandle win32-error=0/f ] keep
|
||||
] keep CloseHandle win32-error=0/f ;
|
||||
|
||||
: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
|
||||
dup
|
||||
GENERIC_READ FILE_SHARE_READ f
|
||||
OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
|
||||
CreateFileW dup INVALID_HANDLE_VALUE = [
|
||||
drop find-first-file-stat WIN32_FIND_DATA>file-info
|
||||
] [
|
||||
nip
|
||||
get-file-information BY_HANDLE_FILE_INFORMATION>file-info
|
||||
] if ;
|
||||
|
||||
M: windows-nt-io file-info ( path -- info )
|
||||
get-file-information-stat ;
|
||||
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
USING: io.files.temporary.backend io.nonblocking io.windows
|
||||
kernel system windows.kernel32 ;
|
||||
|
||||
IN: io.windows.files.temporary
|
||||
|
||||
M: windows-io (temporary-file) ( path -- stream )
|
||||
GENERIC_WRITE CREATE_NEW 0 open-file 0 <win32-file> <writer> ;
|
||||
|
||||
M: windows-io temporary-path ( -- path )
|
||||
"TEMP" os-env ;
|
||||
|
|
@ -1,18 +1,38 @@
|
|||
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays continuations destructors io
|
||||
io.windows libc io.nonblocking io.streams.duplex windows.types
|
||||
math windows.kernel32 windows namespaces io.launcher kernel
|
||||
sequences windows.errors assocs splitting system strings
|
||||
io.windows.launcher io.windows.nt.pipes io.backend
|
||||
combinators ;
|
||||
combinators shuffle ;
|
||||
IN: io.windows.nt.launcher
|
||||
|
||||
: duplicate-handle ( handle -- handle' )
|
||||
GetCurrentProcess ! source process
|
||||
swap ! handle
|
||||
GetCurrentProcess ! target process
|
||||
f <void*> [ ! target handle
|
||||
DUPLICATE_SAME_ACCESS ! desired access
|
||||
TRUE ! inherit handle
|
||||
DUPLICATE_CLOSE_SOURCE ! options
|
||||
DuplicateHandle win32-error=0/f
|
||||
] keep *void* ;
|
||||
|
||||
! The below code is based on the example given in
|
||||
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
|
||||
|
||||
: (redirect) ( path access-mode create-mode -- handle )
|
||||
>r >r
|
||||
: redirect-default ( default obj access-mode create-mode -- handle )
|
||||
3drop ;
|
||||
|
||||
: redirect-inherit ( default obj access-mode create-mode -- handle )
|
||||
4drop f ;
|
||||
|
||||
: redirect-closed ( default obj access-mode create-mode -- handle )
|
||||
drop 2nip null-pipe ;
|
||||
|
||||
: redirect-file ( default path access-mode create-mode -- handle )
|
||||
>r >r >r drop r>
|
||||
normalize-pathname
|
||||
r> ! access-mode
|
||||
share-mode
|
||||
|
|
@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
|
|||
f ! template file
|
||||
CreateFile dup invalid-handle? dup close-later ;
|
||||
|
||||
: redirect ( obj access-mode create-mode -- handle )
|
||||
{
|
||||
{ [ pick not ] [ 3drop f ] }
|
||||
{ [ pick +closed+ eq? ] [ drop nip null-pipe ] }
|
||||
{ [ pick string? ] [ (redirect) ] }
|
||||
} cond ;
|
||||
|
||||
: ?closed or dup t eq? [ drop f ] when ;
|
||||
|
||||
: inherited-stdout ( args -- handle )
|
||||
CreateProcess-args-stdout-pipe
|
||||
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
|
||||
|
||||
: redirect-stdout ( args -- handle )
|
||||
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
|
||||
swap inherited-stdout ?closed ;
|
||||
|
||||
: inherited-stderr ( args -- handle )
|
||||
drop STD_ERROR_HANDLE GetStdHandle ;
|
||||
|
||||
: redirect-stderr ( args -- handle )
|
||||
+stderr+ get
|
||||
dup +stdout+ eq? [
|
||||
drop
|
||||
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
|
||||
] [
|
||||
GENERIC_WRITE CREATE_ALWAYS redirect
|
||||
swap inherited-stderr ?closed
|
||||
] if ;
|
||||
|
||||
: inherited-stdin ( args -- handle )
|
||||
CreateProcess-args-stdin-pipe
|
||||
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
|
||||
|
||||
: redirect-stdin ( args -- handle )
|
||||
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
|
||||
swap inherited-stdin ?closed ;
|
||||
|
||||
: set-inherit ( handle ? -- )
|
||||
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
||||
|
||||
: redirect-stream ( default stream access-mode create-mode -- handle )
|
||||
2drop nip
|
||||
underlying-handle win32-file-handle
|
||||
duplicate-handle dup t set-inherit ;
|
||||
|
||||
: redirect ( default obj access-mode create-mode -- handle )
|
||||
{
|
||||
{ [ pick not ] [ redirect-default ] }
|
||||
{ [ pick +inherit+ eq? ] [ redirect-inherit ] }
|
||||
{ [ pick +closed+ eq? ] [ redirect-closed ] }
|
||||
{ [ pick string? ] [ redirect-file ] }
|
||||
{ [ t ] [ redirect-stream ] }
|
||||
} cond ;
|
||||
|
||||
: default-stdout ( args -- handle )
|
||||
CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
|
||||
|
||||
: redirect-stdout ( args -- handle )
|
||||
default-stdout
|
||||
+stdout+ get
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
STD_OUTPUT_HANDLE GetStdHandle or ;
|
||||
|
||||
: redirect-stderr ( args -- handle )
|
||||
+stderr+ get +stdout+ eq? [
|
||||
CreateProcess-args-lpStartupInfo
|
||||
STARTUPINFO-hStdOutput
|
||||
] [
|
||||
drop
|
||||
f
|
||||
+stderr+ get
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
STD_ERROR_HANDLE GetStdHandle or
|
||||
] if ;
|
||||
|
||||
: default-stdin ( args -- handle )
|
||||
CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
|
||||
|
||||
: redirect-stdin ( args -- handle )
|
||||
default-stdin
|
||||
+stdin+ get
|
||||
GENERIC_READ
|
||||
OPEN_EXISTING
|
||||
redirect
|
||||
STD_INPUT_HANDLE GetStdHandle or ;
|
||||
|
||||
: add-pipe-dtors ( pipe -- )
|
||||
dup
|
||||
pipe-in close-later
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ M: win32-file close-handle ( handle -- )
|
|||
: open-file ( path access-mode create-mode flags -- handle )
|
||||
[
|
||||
>r >r >r normalize-pathname r>
|
||||
share-mode f r> r> CreateFile-flags f CreateFile
|
||||
share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
|
||||
dup invalid-handle? dup close-later
|
||||
dup add-completion
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
|
|||
! are unified
|
||||
: create-method ( class generic -- method )
|
||||
2dup method dup
|
||||
[ 2nip method-word ]
|
||||
[ 2nip ]
|
||||
[ drop 2dup [ ] -rot define-method create-method ] if ;
|
||||
|
||||
: CREATE-METHOD ( -- class generic body )
|
||||
|
|
@ -369,14 +369,14 @@ M: lambda-method definition
|
|||
|
||||
: method-stack-effect
|
||||
dup "lambda" word-prop lambda-vars
|
||||
swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
|
||||
swap "method-generic" word-prop stack-effect
|
||||
dup [ effect-out ] when
|
||||
<effect> ;
|
||||
|
||||
M: lambda-method synopsis*
|
||||
dup definer.
|
||||
dup "method" word-prop dup
|
||||
method-specializer pprint*
|
||||
method-generic pprint*
|
||||
dup dup definer.
|
||||
"method-specializer" word-prop pprint*
|
||||
"method-generic" word-prop pprint*
|
||||
method-stack-effect effect>string comment. ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ HELP: schedule-insomniac
|
|||
{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
|
||||
{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
|
||||
|
||||
ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
|
||||
ARTICLE: "logging.insomniac" "Automated log analysis"
|
||||
"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
|
||||
$nl
|
||||
"Required configuration parameters:"
|
||||
|
|
|
|||
|
|
@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework"
|
|||
{ $subsection "logging.levels" }
|
||||
{ $subsection "logging.messages" }
|
||||
{ $subsection "logging.rotation" }
|
||||
{ $subsection "logging.parser" }
|
||||
{ $subsection "logging.analysis" }
|
||||
{ $subsection "logging.insomniac" }
|
||||
{ $vocab-subsection "Log file parser" "logging.parser" }
|
||||
{ $vocab-subsection "Log analysis" "logging.analysis" }
|
||||
{ $vocab-subsection "Automated log analysis" "logging.insomniac" }
|
||||
{ $subsection "logging.server" } ;
|
||||
|
||||
ABOUT: "logging"
|
||||
|
|
|
|||
|
|
@ -34,6 +34,10 @@ M: real sqrt
|
|||
: set-bit ( x n -- y ) 2^ bitor ; foldable
|
||||
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
|
||||
: bit-set? ( x n -- ? ) bit-clear? not ; foldable
|
||||
: unmask ( x n -- ? ) bitnot bitand ; foldable
|
||||
: unmask? ( x n -- ? ) unmask 0 > ; foldable
|
||||
: mask ( x n -- ? ) bitand ; foldable
|
||||
: mask? ( x n -- ? ) mask 0 > ; foldable
|
||||
|
||||
GENERIC: (^) ( x y -- z ) foldable
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lazy-lists promises kernel sequences strings math
|
||||
arrays splitting quotations combinators namespaces
|
||||
unicode.case unicode.categories ;
|
||||
unicode.case unicode.categories sequences.deep ;
|
||||
IN: parser-combinators
|
||||
|
||||
! Parser combinator protocol
|
||||
|
|
@ -329,11 +329,6 @@ LAZY: <(+)> ( parser -- parser )
|
|||
LAZY: surrounded-by ( parser start end -- parser' )
|
||||
[ token ] 2apply swapd pack ;
|
||||
|
||||
: flatten* ( obj -- )
|
||||
dup array? [ [ flatten* ] each ] [ , ] if ;
|
||||
|
||||
: flatten [ flatten* ] { } make ;
|
||||
|
||||
: exactly-n ( parser n -- parser' )
|
||||
swap <repetition> <and-parser> [ flatten ] <@ ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel parser words arrays strings math.parser sequences
|
||||
quotations vectors namespaces math assocs continuations peg
|
||||
unicode.categories ;
|
||||
peg.parsers unicode.categories ;
|
||||
IN: peg.ebnf
|
||||
|
||||
TUPLE: ebnf-non-terminal symbol ;
|
||||
|
|
@ -182,4 +182,4 @@ DEFER: 'choice'
|
|||
f
|
||||
] if* ;
|
||||
|
||||
: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing
|
||||
: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing
|
||||
|
|
|
|||
|
|
@ -0,0 +1,149 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax peg peg.parsers.private
|
||||
unicode.categories ;
|
||||
IN: peg.parsers
|
||||
|
||||
HELP: (list-of)
|
||||
{ $values
|
||||
{ "items" "a sequence" }
|
||||
{ "separator" "a parser" }
|
||||
{ "repeat1?" "a boolean" }
|
||||
{ "parser" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that returns a list of items separated by the separator parser. Does not hide the separators."
|
||||
} { $see-also list-of list-of-many } ;
|
||||
|
||||
HELP: list-of
|
||||
{ $values
|
||||
{ "items" "a sequence" }
|
||||
{ "separator" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of one or more items."
|
||||
} { $notes "Use " { $link list-of-many } " to ensure a list contains two or more items." }
|
||||
{ $examples
|
||||
{ $example "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" }
|
||||
{ $example "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also list-of-many } ;
|
||||
|
||||
HELP: list-of-many
|
||||
{ $values
|
||||
{ "items" "a sequence" }
|
||||
{ "separator" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of two or more items."
|
||||
} { $notes "Use " { $link list-of } " to return a list of only one item."
|
||||
} { $examples
|
||||
{ $example "\"a\" \"a\" token \",\" token list-of-many parse ." "f" }
|
||||
{ $example "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also list-of } ;
|
||||
|
||||
HELP: epsilon
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that matches the empty sequence."
|
||||
} ;
|
||||
|
||||
HELP: any-char
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that matches the any single character."
|
||||
} ;
|
||||
|
||||
HELP: exactly-n
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
{ "n" "an integer" }
|
||||
{ "parser'" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that matches an exact repetition of the input parser."
|
||||
} { $examples
|
||||
{ $example "\"aaa\" \"a\" token 4 exactly-n parse ." "f" }
|
||||
{ $example "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also at-least-n at-most-n from-m-to-n } ;
|
||||
|
||||
HELP: at-least-n
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
{ "n" "an integer" }
|
||||
{ "parser'" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that matches n or more repetitions of the input parser."
|
||||
} { $examples
|
||||
{ $example "\"aaa\" \"a\" token 4 at-least-n parse ." "f" }
|
||||
{ $example "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also exactly-n at-most-n from-m-to-n } ;
|
||||
|
||||
HELP: at-most-n
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
{ "n" "an integer" }
|
||||
{ "parser'" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that matches n or fewer repetitions of the input parser."
|
||||
} { $examples
|
||||
{ $example "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also exactly-n at-least-n from-m-to-n } ;
|
||||
|
||||
HELP: from-m-to-n
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
{ "m" "an integer" }
|
||||
{ "n" "an integer" }
|
||||
{ "parser'" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that matches between and including m to n repetitions of the input parser."
|
||||
} { $examples
|
||||
{ $example "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" }
|
||||
{ $example "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
{ $example "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
|
||||
} { $see-also exactly-n at-most-n at-least-n } ;
|
||||
|
||||
HELP: pack
|
||||
{ $values
|
||||
{ "begin" "a parser" }
|
||||
{ "body" "a parser" }
|
||||
{ "end" "a parser" }
|
||||
{ "parser'" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden."
|
||||
} { $examples
|
||||
{ $example "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "123" }
|
||||
} { $see-also surrounded-by } ;
|
||||
|
||||
HELP: surrounded-by
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
{ "begin" "a string" }
|
||||
{ "end" "a string" }
|
||||
{ "parser'" "a parser" }
|
||||
} { $description
|
||||
"Calls token on begin and end to make them into string parsers. Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden."
|
||||
} { $examples
|
||||
{ $example "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "123" }
|
||||
} { $see-also pack } ;
|
||||
|
||||
HELP: 'digit'
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that matches a single digit as defined by the " { $link digit? } " word."
|
||||
} { $see-also 'integer' } ;
|
||||
|
||||
HELP: 'integer'
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that matches an integer composed of digits, as defined by the " { $link 'digit' } " word."
|
||||
} { $see-also 'digit' 'string' } ;
|
||||
|
||||
HELP: 'string'
|
||||
{ $values
|
||||
{ "parser" "a parser" }
|
||||
} { $description
|
||||
"Returns a parser that matches an string composed of a \", anything that is not \", and another \"."
|
||||
} { $see-also 'integer' } ;
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
USING: kernel peg peg.parsers tools.test ;
|
||||
IN: peg.parsers.tests
|
||||
|
||||
[ V{ "a" } ]
|
||||
[ "a" "a" token "," token list-of parse parse-result-ast ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" "a" } ]
|
||||
[ "a,a,a,a" "a" token "," token list-of parse parse-result-ast ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "a" "a" token "," token list-of-many parse ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" "a" } ]
|
||||
[ "a,a,a,a" "a" token "," token list-of-many parse parse-result-ast ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "aaa" "a" token 4 exactly-n parse ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" "a" } ]
|
||||
[ "aaaa" "a" token 4 exactly-n parse parse-result-ast ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "aaa" "a" token 4 at-least-n parse ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" "a" } ]
|
||||
[ "aaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" "a" "a" } ]
|
||||
[ "aaaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" "a" } ]
|
||||
[ "aaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" "a" } ]
|
||||
[ "aaaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" } ]
|
||||
[ "aaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" "a" } ]
|
||||
[ "aaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
|
||||
|
||||
[ V{ "a" "a" "a" "a" } ]
|
||||
[ "aaaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
|
||||
|
||||
[ 97 ]
|
||||
[ "a" any-char parse parse-result-ast ] unit-test
|
||||
|
||||
[ V{ } ]
|
||||
[ "" epsilon parse parse-result-ast ] unit-test
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences strings namespaces math assocs shuffle
|
||||
vectors arrays combinators.lib memoize math.parser match
|
||||
unicode.categories sequences.deep peg peg.private ;
|
||||
IN: peg.parsers
|
||||
|
||||
TUPLE: just-parser p1 ;
|
||||
|
||||
: just-pattern
|
||||
[
|
||||
dup [
|
||||
dup parse-result-remaining empty? [ drop f ] unless
|
||||
] when
|
||||
] ;
|
||||
|
||||
|
||||
M: just-parser compile ( parser -- quot )
|
||||
just-parser-p1 compile just-pattern append ;
|
||||
|
||||
MEMO: just ( parser -- parser )
|
||||
just-parser construct-boa init-parser ;
|
||||
|
||||
<PRIVATE
|
||||
MEMO: (list-of) ( items separator repeat1? -- parser )
|
||||
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
|
||||
[ unclip 1vector swap first append ] action ;
|
||||
PRIVATE>
|
||||
|
||||
MEMO: list-of ( items separator -- parser )
|
||||
hide f (list-of) ;
|
||||
|
||||
MEMO: list-of-many ( items separator -- parser )
|
||||
hide t (list-of) ;
|
||||
|
||||
MEMO: epsilon ( -- parser ) V{ } token ;
|
||||
|
||||
MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: flatten-vectors ( pair -- vector )
|
||||
first2 over push-all ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MEMO: exactly-n ( parser n -- parser' )
|
||||
swap <repetition> seq ;
|
||||
|
||||
MEMO: at-most-n ( parser n -- parser' )
|
||||
dup zero? [
|
||||
2drop epsilon
|
||||
] [
|
||||
2dup exactly-n
|
||||
-rot 1- at-most-n 2choice
|
||||
] if ;
|
||||
|
||||
MEMO: at-least-n ( parser n -- parser' )
|
||||
dupd exactly-n swap repeat0 2seq
|
||||
[ flatten-vectors ] action ;
|
||||
|
||||
MEMO: from-m-to-n ( parser m n -- parser' )
|
||||
>r [ exactly-n ] 2keep r> swap - at-most-n 2seq
|
||||
[ flatten-vectors ] action ;
|
||||
|
||||
MEMO: pack ( begin body end -- parser )
|
||||
>r >r hide r> r> hide 3seq [ first ] action ;
|
||||
|
||||
MEMO: surrounded-by ( parser begin end -- parser' )
|
||||
[ token ] 2apply swapd pack ;
|
||||
|
||||
MEMO: 'digit' ( -- parser )
|
||||
[ digit? ] satisfy [ digit> ] action ;
|
||||
|
||||
MEMO: 'integer' ( -- parser )
|
||||
'digit' repeat1 [ 10 digits>integer ] action ;
|
||||
|
||||
MEMO: 'string' ( -- parser )
|
||||
[
|
||||
[ CHAR: " = ] satisfy hide ,
|
||||
[ CHAR: " = not ] satisfy repeat0 ,
|
||||
[ CHAR: " = ] satisfy hide ,
|
||||
] { } make seq [ first >string ] action ;
|
||||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences strings namespaces math assocs shuffle
|
||||
vectors arrays combinators.lib memoize math.parser match
|
||||
unicode.categories ;
|
||||
unicode.categories sequences.lib compiler.units parser
|
||||
words ;
|
||||
IN: peg
|
||||
|
||||
TUPLE: parse-result remaining ast ;
|
||||
|
|
@ -312,6 +313,9 @@ MEMO: range ( min max -- parser )
|
|||
: 3seq ( parser1 parser2 parser3 -- parser )
|
||||
3array seq ;
|
||||
|
||||
: 4seq ( parser1 parser2 parser3 parser4 -- parser )
|
||||
4array seq ;
|
||||
|
||||
: seq* ( quot -- paser )
|
||||
{ } make seq ; inline
|
||||
|
||||
|
|
@ -324,6 +328,9 @@ MEMO: range ( min max -- parser )
|
|||
: 3choice ( parser1 parser2 parser3 -- parser )
|
||||
3array choice ;
|
||||
|
||||
: 4choice ( parser1 parser2 parser3 parser4 -- parser )
|
||||
4array choice ;
|
||||
|
||||
: choice* ( quot -- paser )
|
||||
{ } make choice ; inline
|
||||
|
||||
|
|
@ -354,25 +361,11 @@ MEMO: hide ( parser -- parser )
|
|||
MEMO: delay ( parser -- parser )
|
||||
delay-parser construct-boa init-parser ;
|
||||
|
||||
MEMO: (list-of) ( items separator repeat1? -- parser )
|
||||
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
|
||||
[ unclip 1vector swap first append ] action ;
|
||||
|
||||
MEMO: list-of ( items separator -- parser )
|
||||
hide f (list-of) ;
|
||||
|
||||
MEMO: list-of* ( items separator -- parser )
|
||||
hide t (list-of) ;
|
||||
|
||||
MEMO: 'digit' ( -- parser )
|
||||
[ digit? ] satisfy [ digit> ] action ;
|
||||
|
||||
MEMO: 'integer' ( -- parser )
|
||||
'digit' repeat1 [ 10 digits>integer ] action ;
|
||||
|
||||
MEMO: 'string' ( -- parser )
|
||||
[
|
||||
[ CHAR: " = ] satisfy hide ,
|
||||
[ CHAR: " = not ] satisfy repeat0 ,
|
||||
[ CHAR: " = ] satisfy hide ,
|
||||
] { } make seq [ first >string ] action ;
|
||||
: PEG:
|
||||
(:) [
|
||||
[
|
||||
call compile
|
||||
[ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
|
||||
append define
|
||||
] with-compilation-unit
|
||||
] 2curry over push-all ; parsing
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays strings math.parser sequences peg peg.ebnf memoize ;
|
||||
USING: kernel arrays strings math.parser sequences
|
||||
peg peg.ebnf peg.parsers memoize ;
|
||||
IN: peg.pl0
|
||||
|
||||
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ GENERIC: foo
|
|||
|
||||
M: integer foo + ;
|
||||
|
||||
"resource:extra/tools/test/foo.factor" run-file
|
||||
"resource:extra/tools/crossref/test/foo.factor" run-file
|
||||
|
||||
[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test
|
||||
[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USE: temporary
|
||||
USE: tools.crossref.tests
|
||||
USE: kernel
|
||||
|
||||
1 2 foo drop
|
||||
|
|
@ -29,9 +29,8 @@ M: string (profile.)
|
|||
dup <vocab-profile> write-object ;
|
||||
|
||||
M: method-body (profile.)
|
||||
"method" word-prop
|
||||
dup method-specializer over method-generic 2array synopsis
|
||||
swap method-generic <usage-profile> write-object ;
|
||||
dup synopsis swap "method-generic" word-prop
|
||||
<usage-profile> write-object ;
|
||||
|
||||
: counter. ( obj n -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -445,6 +445,18 @@ C-STRUCT: WIN32_FIND_DATA
|
|||
{ { "TCHAR" 260 } "cFileName" }
|
||||
{ { "TCHAR" 14 } "cAlternateFileName" } ;
|
||||
|
||||
C-STRUCT: BY_HANDLE_FILE_INFORMATION
|
||||
{ "DWORD" "dwFileAttributes" }
|
||||
{ "FILETIME" "ftCreationTime" }
|
||||
{ "FILETIME" "ftLastAccessTime" }
|
||||
{ "FILETIME" "ftLastWriteTime" }
|
||||
{ "DWORD" "dwVolumeSerialNumber" }
|
||||
{ "DWORD" "nFileSizeHigh" }
|
||||
{ "DWORD" "nFileSizeLow" }
|
||||
{ "DWORD" "nNumberOfLinks" }
|
||||
{ "DWORD" "nFileIndexHigh" }
|
||||
{ "DWORD" "nFileIndexLow" } ;
|
||||
|
||||
TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA
|
||||
TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA
|
||||
TYPEDEF: void* POVERLAPPED
|
||||
|
|
|
|||
|
|
@ -1,39 +1,39 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types kernel math windows windows.kernel32
|
||||
namespaces calendar.backend ;
|
||||
IN: windows.time
|
||||
|
||||
: >64bit ( lo hi -- n )
|
||||
32 shift bitor ;
|
||||
|
||||
: windows-1601 ( -- timestamp )
|
||||
1601 1 1 0 0 0 0 <timestamp> ;
|
||||
|
||||
: FILETIME>windows-time ( FILETIME -- n )
|
||||
[ FILETIME-dwLowDateTime ] keep
|
||||
FILETIME-dwHighDateTime >64bit ;
|
||||
|
||||
: windows-time>timestamp ( n -- timestamp )
|
||||
10000000 /i seconds windows-1601 swap time+ ;
|
||||
|
||||
: windows-time ( -- n )
|
||||
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
|
||||
FILETIME>windows-time ;
|
||||
|
||||
: timestamp>windows-time ( timestamp -- n )
|
||||
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
|
||||
>gmt windows-1601 (time-) 10000000 * >integer ;
|
||||
|
||||
: windows-time>FILETIME ( n -- FILETIME )
|
||||
"FILETIME" <c-object>
|
||||
[
|
||||
[ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
|
||||
>r -32 shift r> set-FILETIME-dwHighDateTime
|
||||
] keep ;
|
||||
|
||||
: timestamp>FILETIME ( timestamp -- FILETIME/f )
|
||||
[ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
|
||||
|
||||
: FILETIME>timestamp ( FILETIME -- timestamp/f )
|
||||
FILETIME>windows-time windows-time>timestamp ;
|
||||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types kernel math windows windows.kernel32
|
||||
namespaces calendar calendar.backend ;
|
||||
IN: windows.time
|
||||
|
||||
: >64bit ( lo hi -- n )
|
||||
32 shift bitor ;
|
||||
|
||||
: windows-1601 ( -- timestamp )
|
||||
1601 1 1 0 0 0 0 <timestamp> ;
|
||||
|
||||
: FILETIME>windows-time ( FILETIME -- n )
|
||||
[ FILETIME-dwLowDateTime ] keep
|
||||
FILETIME-dwHighDateTime >64bit ;
|
||||
|
||||
: windows-time>timestamp ( n -- timestamp )
|
||||
10000000 /i seconds windows-1601 swap time+ ;
|
||||
|
||||
: windows-time ( -- n )
|
||||
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
|
||||
FILETIME>windows-time ;
|
||||
|
||||
: timestamp>windows-time ( timestamp -- n )
|
||||
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
|
||||
>gmt windows-1601 (time-) 10000000 * >integer ;
|
||||
|
||||
: windows-time>FILETIME ( n -- FILETIME )
|
||||
"FILETIME" <c-object>
|
||||
[
|
||||
[ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
|
||||
>r -32 shift r> set-FILETIME-dwHighDateTime
|
||||
] keep ;
|
||||
|
||||
: timestamp>FILETIME ( timestamp -- FILETIME/f )
|
||||
[ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
|
||||
|
||||
: FILETIME>timestamp ( FILETIME -- timestamp/f )
|
||||
FILETIME>windows-time windows-time>timestamp ;
|
||||
|
|
|
|||
509
misc/factor.sh
509
misc/factor.sh
|
|
@ -15,246 +15,247 @@ GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
|
|||
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
|
||||
|
||||
test_program_installed() {
|
||||
if ! [[ -n `type -p $1` ]] ; then
|
||||
return 0;
|
||||
fi
|
||||
return 1;
|
||||
if ! [[ -n `type -p $1` ]] ; then
|
||||
return 0;
|
||||
fi
|
||||
return 1;
|
||||
}
|
||||
|
||||
ensure_program_installed() {
|
||||
installed=0;
|
||||
for i in $* ;
|
||||
do
|
||||
echo -n "Checking for $i..."
|
||||
test_program_installed $i
|
||||
if [[ $? -eq 0 ]]; then
|
||||
echo -n "not "
|
||||
else
|
||||
installed=$(( $installed + 1 ))
|
||||
fi
|
||||
echo "found!"
|
||||
done
|
||||
if [[ $installed -eq 0 ]] ; then
|
||||
echo -n "Install "
|
||||
if [[ $# -eq 1 ]] ; then
|
||||
echo -n $1
|
||||
else
|
||||
echo -n "any of [ $* ]"
|
||||
fi
|
||||
echo " and try again."
|
||||
exit 1
|
||||
fi
|
||||
installed=0;
|
||||
for i in $* ;
|
||||
do
|
||||
echo -n "Checking for $i..."
|
||||
test_program_installed $i
|
||||
if [[ $? -eq 0 ]]; then
|
||||
echo -n "not "
|
||||
else
|
||||
installed=$(( $installed + 1 ))
|
||||
fi
|
||||
echo "found!"
|
||||
done
|
||||
if [[ $installed -eq 0 ]] ; then
|
||||
echo -n "Install "
|
||||
if [[ $# -eq 1 ]] ; then
|
||||
echo -n $1
|
||||
else
|
||||
echo -n "any of [ $* ]"
|
||||
fi
|
||||
echo " and try again."
|
||||
exit 1
|
||||
fi
|
||||
}
|
||||
|
||||
check_ret() {
|
||||
RET=$?
|
||||
if [[ $RET -ne 0 ]] ; then
|
||||
echo $1 failed
|
||||
exit 2
|
||||
fi
|
||||
RET=$?
|
||||
if [[ $RET -ne 0 ]] ; then
|
||||
echo $1 failed
|
||||
exit 2
|
||||
fi
|
||||
}
|
||||
|
||||
check_gcc_version() {
|
||||
echo -n "Checking gcc version..."
|
||||
GCC_VERSION=`gcc --version`
|
||||
check_ret gcc
|
||||
if [[ $GCC_VERSION == *3.3.* ]] ; then
|
||||
echo "bad!"
|
||||
echo "You have a known buggy version of gcc (3.3)"
|
||||
echo "Install gcc 3.4 or higher and try again."
|
||||
exit 3
|
||||
fi
|
||||
echo "ok."
|
||||
echo -n "Checking gcc version..."
|
||||
GCC_VERSION=`gcc --version`
|
||||
check_ret gcc
|
||||
if [[ $GCC_VERSION == *3.3.* ]] ; then
|
||||
echo "bad!"
|
||||
echo "You have a known buggy version of gcc (3.3)"
|
||||
echo "Install gcc 3.4 or higher and try again."
|
||||
exit 3
|
||||
fi
|
||||
echo "ok."
|
||||
}
|
||||
|
||||
set_downloader() {
|
||||
test_program_installed wget
|
||||
if [[ $? -ne 0 ]] ; then
|
||||
DOWNLOAD=wget
|
||||
else
|
||||
DOWNLOAD="curl -O"
|
||||
fi
|
||||
test_program_installed wget
|
||||
if [[ $? -ne 0 ]] ; then
|
||||
DOWNLOAD=wget
|
||||
else
|
||||
DOWNLOAD="curl -O"
|
||||
fi
|
||||
}
|
||||
|
||||
set_md5sum() {
|
||||
test_program_installed md5sum
|
||||
if [[ $? -ne 0 ]] ; then
|
||||
MD5SUM=md5sum
|
||||
else
|
||||
MD5SUM="md5 -r"
|
||||
fi
|
||||
test_program_installed md5sum
|
||||
if [[ $? -ne 0 ]] ; then
|
||||
MD5SUM=md5sum
|
||||
else
|
||||
MD5SUM="md5 -r"
|
||||
fi
|
||||
}
|
||||
|
||||
check_installed_programs() {
|
||||
ensure_program_installed chmod
|
||||
ensure_program_installed uname
|
||||
ensure_program_installed git
|
||||
ensure_program_installed wget curl
|
||||
ensure_program_installed gcc
|
||||
ensure_program_installed make
|
||||
ensure_program_installed md5sum md5
|
||||
ensure_program_installed cut
|
||||
case $OS in
|
||||
netbsd) ensure_program_installed gmake;;
|
||||
esac
|
||||
check_gcc_version
|
||||
ensure_program_installed chmod
|
||||
ensure_program_installed uname
|
||||
ensure_program_installed git
|
||||
ensure_program_installed wget curl
|
||||
ensure_program_installed gcc
|
||||
ensure_program_installed make
|
||||
ensure_program_installed md5sum md5
|
||||
ensure_program_installed cut
|
||||
case $OS in
|
||||
macosx) ensure_program_installed port;;
|
||||
netbsd) ensure_program_installed gmake;;
|
||||
esac
|
||||
check_gcc_version
|
||||
}
|
||||
|
||||
check_library_exists() {
|
||||
GCC_TEST=factor-library-test.c
|
||||
GCC_OUT=factor-library-test.out
|
||||
echo -n "Checking for library $1..."
|
||||
echo "int main(){return 0;}" > $GCC_TEST
|
||||
gcc $GCC_TEST -o $GCC_OUT -l $1
|
||||
if [[ $? -ne 0 ]] ; then
|
||||
echo "not found!"
|
||||
echo "Warning: library $1 not found."
|
||||
echo "***Factor will compile NO_UI=1"
|
||||
NO_UI=1
|
||||
fi
|
||||
rm -f $GCC_TEST
|
||||
check_ret rm
|
||||
rm -f $GCC_OUT
|
||||
check_ret rm
|
||||
echo "found."
|
||||
GCC_TEST=factor-library-test.c
|
||||
GCC_OUT=factor-library-test.out
|
||||
echo -n "Checking for library $1..."
|
||||
echo "int main(){return 0;}" > $GCC_TEST
|
||||
gcc $GCC_TEST -o $GCC_OUT -l $1
|
||||
if [[ $? -ne 0 ]] ; then
|
||||
echo "not found!"
|
||||
echo "Warning: library $1 not found."
|
||||
echo "***Factor will compile NO_UI=1"
|
||||
NO_UI=1
|
||||
fi
|
||||
rm -f $GCC_TEST
|
||||
check_ret rm
|
||||
rm -f $GCC_OUT
|
||||
check_ret rm
|
||||
echo "found."
|
||||
}
|
||||
|
||||
check_X11_libraries() {
|
||||
check_library_exists freetype
|
||||
check_library_exists GLU
|
||||
check_library_exists GL
|
||||
check_library_exists X11
|
||||
check_library_exists freetype
|
||||
check_library_exists GLU
|
||||
check_library_exists GL
|
||||
check_library_exists X11
|
||||
}
|
||||
|
||||
check_libraries() {
|
||||
case $OS in
|
||||
linux) check_X11_libraries;;
|
||||
esac
|
||||
case $OS in
|
||||
linux) check_X11_libraries;;
|
||||
esac
|
||||
}
|
||||
|
||||
check_factor_exists() {
|
||||
if [[ -d "factor" ]] ; then
|
||||
echo "A directory called 'factor' already exists."
|
||||
echo "Rename or delete it and try again."
|
||||
exit 4
|
||||
fi
|
||||
if [[ -d "factor" ]] ; then
|
||||
echo "A directory called 'factor' already exists."
|
||||
echo "Rename or delete it and try again."
|
||||
exit 4
|
||||
fi
|
||||
}
|
||||
|
||||
find_os() {
|
||||
echo "Finding OS..."
|
||||
uname_s=`uname -s`
|
||||
check_ret uname
|
||||
case $uname_s in
|
||||
CYGWIN_NT-5.2-WOW64) OS=winnt;;
|
||||
*CYGWIN_NT*) OS=winnt;;
|
||||
*CYGWIN*) OS=winnt;;
|
||||
*darwin*) OS=macosx;;
|
||||
*Darwin*) OS=macosx;;
|
||||
*linux*) OS=linux;;
|
||||
*Linux*) OS=linux;;
|
||||
*NetBSD*) OS=netbsd;;
|
||||
esac
|
||||
echo "Finding OS..."
|
||||
uname_s=`uname -s`
|
||||
check_ret uname
|
||||
case $uname_s in
|
||||
CYGWIN_NT-5.2-WOW64) OS=winnt;;
|
||||
*CYGWIN_NT*) OS=winnt;;
|
||||
*CYGWIN*) OS=winnt;;
|
||||
*darwin*) OS=macosx;;
|
||||
*Darwin*) OS=macosx;;
|
||||
*linux*) OS=linux;;
|
||||
*Linux*) OS=linux;;
|
||||
*NetBSD*) OS=netbsd;;
|
||||
esac
|
||||
}
|
||||
|
||||
find_architecture() {
|
||||
echo "Finding ARCH..."
|
||||
uname_m=`uname -m`
|
||||
check_ret uname
|
||||
case $uname_m in
|
||||
i386) ARCH=x86;;
|
||||
i686) ARCH=x86;;
|
||||
*86) ARCH=x86;;
|
||||
*86_64) ARCH=x86;;
|
||||
"Power Macintosh") ARCH=ppc;;
|
||||
esac
|
||||
echo "Finding ARCH..."
|
||||
uname_m=`uname -m`
|
||||
check_ret uname
|
||||
case $uname_m in
|
||||
i386) ARCH=x86;;
|
||||
i686) ARCH=x86;;
|
||||
*86) ARCH=x86;;
|
||||
*86_64) ARCH=x86;;
|
||||
"Power Macintosh") ARCH=ppc;;
|
||||
esac
|
||||
}
|
||||
|
||||
write_test_program() {
|
||||
echo "#include <stdio.h>" > $C_WORD.c
|
||||
echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
|
||||
echo "#include <stdio.h>" > $C_WORD.c
|
||||
echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
|
||||
}
|
||||
|
||||
find_word_size() {
|
||||
echo "Finding WORD..."
|
||||
C_WORD=factor-word-size
|
||||
write_test_program
|
||||
gcc -o $C_WORD $C_WORD.c
|
||||
WORD=$(./$C_WORD)
|
||||
check_ret $C_WORD
|
||||
rm -f $C_WORD*
|
||||
echo "Finding WORD..."
|
||||
C_WORD=factor-word-size
|
||||
write_test_program
|
||||
gcc -o $C_WORD $C_WORD.c
|
||||
WORD=$(./$C_WORD)
|
||||
check_ret $C_WORD
|
||||
rm -f $C_WORD*
|
||||
}
|
||||
|
||||
set_factor_binary() {
|
||||
case $OS in
|
||||
# winnt) FACTOR_BINARY=factor-nt;;
|
||||
# macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
|
||||
*) FACTOR_BINARY=factor;;
|
||||
esac
|
||||
case $OS in
|
||||
# winnt) FACTOR_BINARY=factor-nt;;
|
||||
# macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
|
||||
*) FACTOR_BINARY=factor;;
|
||||
esac
|
||||
}
|
||||
|
||||
echo_build_info() {
|
||||
echo OS=$OS
|
||||
echo ARCH=$ARCH
|
||||
echo WORD=$WORD
|
||||
echo FACTOR_BINARY=$FACTOR_BINARY
|
||||
echo MAKE_TARGET=$MAKE_TARGET
|
||||
echo BOOT_IMAGE=$BOOT_IMAGE
|
||||
echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
|
||||
echo GIT_PROTOCOL=$GIT_PROTOCOL
|
||||
echo GIT_URL=$GIT_URL
|
||||
echo OS=$OS
|
||||
echo ARCH=$ARCH
|
||||
echo WORD=$WORD
|
||||
echo FACTOR_BINARY=$FACTOR_BINARY
|
||||
echo MAKE_TARGET=$MAKE_TARGET
|
||||
echo BOOT_IMAGE=$BOOT_IMAGE
|
||||
echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
|
||||
echo GIT_PROTOCOL=$GIT_PROTOCOL
|
||||
echo GIT_URL=$GIT_URL
|
||||
}
|
||||
|
||||
set_build_info() {
|
||||
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
|
||||
echo "OS: $OS"
|
||||
echo "ARCH: $ARCH"
|
||||
echo "WORD: $WORD"
|
||||
echo "OS, ARCH, or WORD is empty. Please report this"
|
||||
exit 5
|
||||
fi
|
||||
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
|
||||
echo "OS: $OS"
|
||||
echo "ARCH: $ARCH"
|
||||
echo "WORD: $WORD"
|
||||
echo "OS, ARCH, or WORD is empty. Please report this"
|
||||
exit 5
|
||||
fi
|
||||
|
||||
MAKE_TARGET=$OS-$ARCH-$WORD
|
||||
MAKE_IMAGE_TARGET=$ARCH.$WORD
|
||||
BOOT_IMAGE=boot.$ARCH.$WORD.image
|
||||
if [[ $OS == macosx && $ARCH == ppc ]] ; then
|
||||
MAKE_IMAGE_TARGET=$OS-$ARCH
|
||||
MAKE_TARGET=$OS-$ARCH
|
||||
BOOT_IMAGE=boot.macosx-ppc.image
|
||||
fi
|
||||
if [[ $OS == linux && $ARCH == ppc ]] ; then
|
||||
MAKE_IMAGE_TARGET=$OS-$ARCH
|
||||
MAKE_TARGET=$OS-$ARCH
|
||||
BOOT_IMAGE=boot.linux-ppc.image
|
||||
fi
|
||||
MAKE_TARGET=$OS-$ARCH-$WORD
|
||||
MAKE_IMAGE_TARGET=$ARCH.$WORD
|
||||
BOOT_IMAGE=boot.$ARCH.$WORD.image
|
||||
if [[ $OS == macosx && $ARCH == ppc ]] ; then
|
||||
MAKE_IMAGE_TARGET=$OS-$ARCH
|
||||
MAKE_TARGET=$OS-$ARCH
|
||||
BOOT_IMAGE=boot.macosx-ppc.image
|
||||
fi
|
||||
if [[ $OS == linux && $ARCH == ppc ]] ; then
|
||||
MAKE_IMAGE_TARGET=$OS-$ARCH
|
||||
MAKE_TARGET=$OS-$ARCH
|
||||
BOOT_IMAGE=boot.linux-ppc.image
|
||||
fi
|
||||
}
|
||||
|
||||
find_build_info() {
|
||||
find_os
|
||||
find_architecture
|
||||
find_word_size
|
||||
set_factor_binary
|
||||
set_build_info
|
||||
echo_build_info
|
||||
find_os
|
||||
find_architecture
|
||||
find_word_size
|
||||
set_factor_binary
|
||||
set_build_info
|
||||
echo_build_info
|
||||
}
|
||||
|
||||
invoke_git() {
|
||||
git $*
|
||||
check_ret git
|
||||
git $*
|
||||
check_ret git
|
||||
}
|
||||
|
||||
git_clone() {
|
||||
echo "Downloading the git repository from factorcode.org..."
|
||||
invoke_git clone $GIT_URL
|
||||
echo "Downloading the git repository from factorcode.org..."
|
||||
invoke_git clone $GIT_URL
|
||||
}
|
||||
|
||||
git_pull_factorcode() {
|
||||
echo "Updating the git repository from factorcode.org..."
|
||||
invoke_git pull $GIT_URL master
|
||||
echo "Updating the git repository from factorcode.org..."
|
||||
invoke_git pull $GIT_URL master
|
||||
}
|
||||
|
||||
cd_factor() {
|
||||
cd factor
|
||||
check_ret cd
|
||||
cd factor
|
||||
check_ret cd
|
||||
}
|
||||
|
||||
invoke_make() {
|
||||
|
|
@ -267,128 +268,134 @@ invoke_make() {
|
|||
}
|
||||
|
||||
make_clean() {
|
||||
invoke_make clean
|
||||
invoke_make clean
|
||||
}
|
||||
|
||||
make_factor() {
|
||||
invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
|
||||
invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
|
||||
}
|
||||
|
||||
update_boot_images() {
|
||||
echo "Deleting old images..."
|
||||
rm checksums.txt* > /dev/null 2>&1
|
||||
rm $BOOT_IMAGE.* > /dev/null 2>&1
|
||||
rm staging.*.image > /dev/null 2>&1
|
||||
if [[ -f $BOOT_IMAGE ]] ; then
|
||||
get_url http://factorcode.org/images/latest/checksums.txt
|
||||
factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
|
||||
set_md5sum
|
||||
disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`;
|
||||
echo "Factorcode md5: $factorcode_md5";
|
||||
echo "Disk md5: $disk_md5";
|
||||
if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
|
||||
echo "Your disk boot image matches the one on factorcode.org."
|
||||
else
|
||||
rm $BOOT_IMAGE > /dev/null 2>&1
|
||||
get_boot_image;
|
||||
fi
|
||||
else
|
||||
get_boot_image
|
||||
fi
|
||||
echo "Deleting old images..."
|
||||
rm checksums.txt* > /dev/null 2>&1
|
||||
rm $BOOT_IMAGE.* > /dev/null 2>&1
|
||||
rm staging.*.image > /dev/null 2>&1
|
||||
if [[ -f $BOOT_IMAGE ]] ; then
|
||||
get_url http://factorcode.org/images/latest/checksums.txt
|
||||
factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
|
||||
set_md5sum
|
||||
disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`;
|
||||
echo "Factorcode md5: $factorcode_md5";
|
||||
echo "Disk md5: $disk_md5";
|
||||
if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
|
||||
echo "Your disk boot image matches the one on factorcode.org."
|
||||
else
|
||||
rm $BOOT_IMAGE > /dev/null 2>&1
|
||||
get_boot_image;
|
||||
fi
|
||||
else
|
||||
get_boot_image
|
||||
fi
|
||||
}
|
||||
|
||||
get_boot_image() {
|
||||
echo "Downloading boot image $BOOT_IMAGE."
|
||||
get_url http://factorcode.org/images/latest/$BOOT_IMAGE
|
||||
echo "Downloading boot image $BOOT_IMAGE."
|
||||
get_url http://factorcode.org/images/latest/$BOOT_IMAGE
|
||||
}
|
||||
|
||||
get_url() {
|
||||
if [[ $DOWNLOAD -eq "" ]] ; then
|
||||
set_downloader;
|
||||
fi
|
||||
echo $DOWNLOAD $1 ;
|
||||
$DOWNLOAD $1
|
||||
check_ret $DOWNLOAD
|
||||
if [[ $DOWNLOAD -eq "" ]] ; then
|
||||
set_downloader;
|
||||
fi
|
||||
echo $DOWNLOAD $1 ;
|
||||
$DOWNLOAD $1
|
||||
check_ret $DOWNLOAD
|
||||
}
|
||||
|
||||
maybe_download_dlls() {
|
||||
if [[ $OS == winnt ]] ; then
|
||||
get_url http://factorcode.org/dlls/freetype6.dll
|
||||
get_url http://factorcode.org/dlls/zlib1.dll
|
||||
get_url http://factorcode.org/dlls/OpenAL32.dll
|
||||
get_url http://factorcode.org/dlls/alut.dll
|
||||
get_url http://factorcode.org/dlls/ogg.dll
|
||||
get_url http://factorcode.org/dlls/theora.dll
|
||||
get_url http://factorcode.org/dlls/vorbis.dll
|
||||
get_url http://factorcode.org/dlls/sqlite3.dll
|
||||
chmod 777 *.dll
|
||||
check_ret chmod
|
||||
fi
|
||||
if [[ $OS == winnt ]] ; then
|
||||
get_url http://factorcode.org/dlls/freetype6.dll
|
||||
get_url http://factorcode.org/dlls/zlib1.dll
|
||||
get_url http://factorcode.org/dlls/OpenAL32.dll
|
||||
get_url http://factorcode.org/dlls/alut.dll
|
||||
get_url http://factorcode.org/dlls/ogg.dll
|
||||
get_url http://factorcode.org/dlls/theora.dll
|
||||
get_url http://factorcode.org/dlls/vorbis.dll
|
||||
get_url http://factorcode.org/dlls/sqlite3.dll
|
||||
chmod 777 *.dll
|
||||
check_ret chmod
|
||||
fi
|
||||
}
|
||||
|
||||
get_config_info() {
|
||||
find_build_info
|
||||
check_installed_programs
|
||||
check_libraries
|
||||
find_build_info
|
||||
check_installed_programs
|
||||
check_libraries
|
||||
}
|
||||
|
||||
bootstrap() {
|
||||
./$FACTOR_BINARY -i=$BOOT_IMAGE
|
||||
./$FACTOR_BINARY -i=$BOOT_IMAGE
|
||||
}
|
||||
|
||||
install() {
|
||||
check_factor_exists
|
||||
get_config_info
|
||||
git_clone
|
||||
cd_factor
|
||||
make_factor
|
||||
get_boot_image
|
||||
maybe_download_dlls
|
||||
bootstrap
|
||||
check_factor_exists
|
||||
get_config_info
|
||||
git_clone
|
||||
cd_factor
|
||||
make_factor
|
||||
get_boot_image
|
||||
maybe_download_dlls
|
||||
bootstrap
|
||||
}
|
||||
|
||||
|
||||
update() {
|
||||
get_config_info
|
||||
git_pull_factorcode
|
||||
make_clean
|
||||
make_factor
|
||||
get_config_info
|
||||
git_pull_factorcode
|
||||
make_clean
|
||||
make_factor
|
||||
}
|
||||
|
||||
update_bootstrap() {
|
||||
update_boot_images
|
||||
bootstrap
|
||||
update_boot_images
|
||||
bootstrap
|
||||
}
|
||||
|
||||
refresh_image() {
|
||||
./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
|
||||
check_ret factor
|
||||
./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
|
||||
check_ret factor
|
||||
}
|
||||
|
||||
make_boot_image() {
|
||||
./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit"
|
||||
check_ret factor
|
||||
./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit"
|
||||
check_ret factor
|
||||
|
||||
}
|
||||
|
||||
install_libraries() {
|
||||
yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
|
||||
check_ret sudo
|
||||
install_libraries_apt() {
|
||||
yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
|
||||
check_ret sudo
|
||||
}
|
||||
|
||||
install_libraries_port() {
|
||||
ensure_program_installed port
|
||||
yes | sudo port install git-core
|
||||
}
|
||||
|
||||
usage() {
|
||||
echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|net-bootstrap"
|
||||
echo "If you are behind a firewall, invoke as:"
|
||||
echo "env GIT_PROTOCOL=http $0 <command>"
|
||||
echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap"
|
||||
echo "If you are behind a firewall, invoke as:"
|
||||
echo "env GIT_PROTOCOL=http $0 <command>"
|
||||
}
|
||||
|
||||
case "$1" in
|
||||
install) install ;;
|
||||
install-x11) install_libraries; install ;;
|
||||
self-update) update; make_boot_image; bootstrap;;
|
||||
quick-update) update; refresh_image ;;
|
||||
update) update; update_bootstrap ;;
|
||||
bootstrap) get_config_info; bootstrap ;;
|
||||
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
|
||||
*) usage ;;
|
||||
install) install ;;
|
||||
install-x11) install_libraries_apt; install ;;
|
||||
install-macosx) install_libraries_port; install ;;
|
||||
self-update) update; make_boot_image; bootstrap;;
|
||||
quick-update) update; refresh_image ;;
|
||||
update) update; update_bootstrap ;;
|
||||
bootstrap) get_config_info; bootstrap ;;
|
||||
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
|
||||
*) usage ;;
|
||||
esac
|
||||
|
|
|
|||
Loading…
Reference in New Issue