Merge branch 'master' of git://factorcode.org/git/factor
commit
65f30a07a1
|
@ -91,6 +91,6 @@ $nl
|
|||
ARTICLE: "c-unions" "C unions"
|
||||
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
|
||||
{ $subsection POSTPONE: C-UNION: }
|
||||
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||
$nl
|
||||
"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
USING: help.syntax help.markup generator.fixup math kernel
|
||||
words strings alien byte-array ;
|
||||
USING: help.syntax help.markup math kernel
|
||||
words strings alien ;
|
||||
IN: generator.fixup
|
||||
|
||||
HELP: frame-required
|
||||
{ $values { "n" "a non-negative integer" } }
|
||||
|
|
|
@ -436,8 +436,13 @@ subbclass "SUBCLASS" {
|
|||
{ "b" "B" TEXT }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: fubbclass < subbclass ;
|
||||
|
||||
fubbclass "FUBCLASS" { } define-persistent
|
||||
|
||||
: test-db-inheritance ( -- )
|
||||
[ ] [ subbclass ensure-table ] unit-test
|
||||
[ ] [ fubbclass ensure-table ] unit-test
|
||||
|
||||
[ ] [
|
||||
subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
|
||||
|
@ -446,7 +451,11 @@ subbclass "SUBCLASS" {
|
|||
[ t "hi" 5 ] [
|
||||
subbclass new "id" get >>id select-tuple
|
||||
[ subbclass? ] [ b>> ] [ a>> ] tri
|
||||
] unit-test ;
|
||||
] unit-test
|
||||
|
||||
[ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
|
||||
|
||||
[ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
|
||||
|
||||
[ test-db-inheritance ] test-sqlite
|
||||
|
||||
|
|
|
@ -0,0 +1,24 @@
|
|||
IN: logging.tests
|
||||
USING: tools.test logging math ;
|
||||
|
||||
: input-logging-test ( a b -- c ) + ;
|
||||
|
||||
\ input-logging-test NOTICE add-input-logging
|
||||
|
||||
: output-logging-test ( a b -- c ) + ;
|
||||
|
||||
\ output-logging-test DEBUG add-output-logging
|
||||
|
||||
: error-logging-test ( a b -- c ) / ;
|
||||
|
||||
\ error-logging-test ERROR add-error-logging
|
||||
|
||||
"logging-test" [
|
||||
[ 4 ] [ 1 3 input-logging-test ] unit-test
|
||||
|
||||
[ 4 ] [ 1 3 output-logging-test ] unit-test
|
||||
|
||||
[ 4/3 ] [ 4 3 error-logging-test ] unit-test
|
||||
|
||||
[ f ] [ 1 0 error-logging-test ] unit-test
|
||||
] with-logging
|
|
@ -4,33 +4,26 @@ USING: logging.server sequences namespaces concurrency.messaging
|
|||
words kernel arrays shuffle tools.annotations
|
||||
prettyprint.config prettyprint debugger io.streams.string
|
||||
splitting continuations effects arrays.lib parser strings
|
||||
combinators.lib quotations ;
|
||||
combinators.lib quotations fry symbols accessors ;
|
||||
IN: logging
|
||||
|
||||
SYMBOL: DEBUG
|
||||
SYMBOL: NOTICE
|
||||
SYMBOL: WARNING
|
||||
SYMBOL: ERROR
|
||||
SYMBOL: CRITICAL
|
||||
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
|
||||
|
||||
: log-levels
|
||||
{ DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
|
||||
: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
|
||||
|
||||
: send-to-log-server ( array string -- )
|
||||
prefix "log-server" get send ;
|
||||
|
||||
SYMBOL: log-service
|
||||
|
||||
: check-log-message
|
||||
pick string?
|
||||
pick word?
|
||||
pick word? and and
|
||||
[ "Bad parameters to log-message" throw ] unless ;
|
||||
: check-log-message ( msg word level -- msg word level )
|
||||
3dup [ string? ] [ word? ] [ word? ] tri* and and
|
||||
[ "Bad parameters to log-message" throw ] unless ; inline
|
||||
|
||||
: log-message ( msg word level -- )
|
||||
check-log-message
|
||||
log-service get dup [
|
||||
>r >r >r string-lines r> word-name r> word-name r>
|
||||
[ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip
|
||||
4array "log-message" send-to-log-server
|
||||
] [
|
||||
4drop
|
||||
|
@ -69,7 +62,7 @@ SYMBOL: log-service
|
|||
PRIVATE>
|
||||
|
||||
: (define-logging) ( word level quot -- )
|
||||
>r >r dup r> r> 2curry annotate ;
|
||||
[ dup ] 2dip 2curry annotate ;
|
||||
|
||||
: call-logging-quot ( quot word level -- quot' )
|
||||
"called" -rot [ log-message ] 3curry prepose ;
|
||||
|
@ -79,31 +72,30 @@ PRIVATE>
|
|||
|
||||
: log-stack ( n word level -- )
|
||||
log-service get [
|
||||
>r >r [ ndup ] keep narray stack>message
|
||||
r> r> log-message
|
||||
[ [ ndup ] keep narray stack>message ] 2dip log-message
|
||||
] [
|
||||
3drop
|
||||
] if ; inline
|
||||
|
||||
: input# stack-effect effect-in length ;
|
||||
: input# stack-effect in>> length ;
|
||||
|
||||
: input-logging-quot ( quot word level -- quot' )
|
||||
over input# -rot [ log-stack ] 3curry prepose ;
|
||||
rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;
|
||||
|
||||
: add-input-logging ( word level -- )
|
||||
[ input-logging-quot ] (define-logging) ;
|
||||
|
||||
: output# stack-effect effect-out length ;
|
||||
: output# stack-effect out>> length ;
|
||||
|
||||
: output-logging-quot ( quot word level -- quot' )
|
||||
over output# -rot [ log-stack ] 3curry compose ;
|
||||
[ [ output# ] keep ] dip '[ @ , , , log-stack ] ;
|
||||
|
||||
: add-output-logging ( word level -- )
|
||||
[ output-logging-quot ] (define-logging) ;
|
||||
|
||||
: (log-error) ( object word level -- )
|
||||
log-service get [
|
||||
>r >r [ print-error ] with-string-writer r> r> log-message
|
||||
[ [ print-error ] with-string-writer ] 2dip log-message
|
||||
] [
|
||||
2drop rethrow
|
||||
] if ;
|
||||
|
@ -112,22 +104,21 @@ PRIVATE>
|
|||
|
||||
: log-critical ( error word -- ) CRITICAL (log-error) ;
|
||||
|
||||
: stack-balancer ( effect word -- quot )
|
||||
>r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
|
||||
swap effect-out length f <repetition> append >quotation ;
|
||||
: stack-balancer ( effect -- quot )
|
||||
[ in>> length [ ndrop ] curry ]
|
||||
[ out>> length f <repetition> >quotation ]
|
||||
bi append ;
|
||||
|
||||
: error-logging-quot ( quot word -- quot' )
|
||||
[ [ log-error ] curry ] keep
|
||||
[ stack-effect ] keep stack-balancer compose
|
||||
[ recover ] 2curry ;
|
||||
dup stack-effect stack-balancer
|
||||
'[ , [ , log-error @ ] recover ] ;
|
||||
|
||||
: add-error-logging ( word level -- )
|
||||
[ over >r input-logging-quot r> error-logging-quot ]
|
||||
[ [ input-logging-quot ] 2keep drop error-logging-quot ]
|
||||
(define-logging) ;
|
||||
|
||||
: LOG:
|
||||
#! Syntax: name level
|
||||
CREATE-WORD
|
||||
dup scan-word
|
||||
[ >r >r 1array stack>message r> r> log-message ] 2curry
|
||||
CREATE-WORD dup scan-word
|
||||
'[ 1array stack>message , , log-message ]
|
||||
define ; parsing
|
||||
|
|
Loading…
Reference in New Issue