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

db4
Doug Coleman 2008-05-30 19:10:04 -05:00
commit 65f30a07a1
5 changed files with 61 additions and 36 deletions

View File

@ -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: } "." ;

View File

@ -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" } }

View File

@ -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

View File

@ -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

View File

@ -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