Merge branch 'master' of factorcode.org:/git/factor
commit
ef9a59c51f
|
@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings
|
|||
alien.structs alien.syntax cpu.architecture alien inspector
|
||||
quotations assocs kernel.private threads continuations.private
|
||||
libc combinators compiler.errors continuations layouts accessors
|
||||
;
|
||||
init ;
|
||||
IN: alien.compiler
|
||||
|
||||
TUPLE: #alien-node < node return parameters abi ;
|
||||
|
@ -336,7 +336,7 @@ M: #alien-indirect generate-node
|
|||
! this hashtable, they will all be blown away by code GC, beware
|
||||
SYMBOL: callbacks
|
||||
|
||||
callbacks global [ H{ } assoc-like ] change-at
|
||||
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
|
||||
|
||||
: register-callback ( word -- ) dup callbacks get set-at ;
|
||||
|
||||
|
@ -344,7 +344,7 @@ M: alien-callback-error summary
|
|||
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
|
||||
|
||||
: callback-bottom ( node -- )
|
||||
xt>> [ word-xt drop <alien> ] curry
|
||||
xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
|
||||
recursive-state get infer-quot ;
|
||||
|
||||
\ alien-callback [
|
||||
|
@ -354,7 +354,7 @@ M: alien-callback-error summary
|
|||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>return
|
||||
gensym dup register-callback >>xt
|
||||
gensym >>xt
|
||||
callback-bottom
|
||||
] "infer" set-word-prop
|
||||
|
||||
|
|
|
@ -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" } }
|
||||
|
|
|
@ -35,10 +35,8 @@ IN: bunny.model
|
|||
[ normalize ] map ;
|
||||
|
||||
: read-model ( stream -- model )
|
||||
"Reading model" print flush [
|
||||
ascii [ parse-model ] with-file-reader
|
||||
[ normals ] 2keep 3array
|
||||
] time ;
|
||||
ascii [ parse-model ] with-file-reader
|
||||
[ normals ] 2keep 3array ;
|
||||
|
||||
: model-path "bun_zipper.ply" temp-file ;
|
||||
|
||||
|
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel ;
|
||||
IN: db.errors
|
||||
|
||||
ERROR: db-error ;
|
||||
ERROR: sql-error ;
|
||||
|
||||
|
||||
ERROR: table-exists ;
|
||||
ERROR: bad-schema ;
|
|
@ -175,7 +175,7 @@ M: postgresql-db create-sql-statement ( class -- seq )
|
|||
|
||||
: drop-table-sql ( table -- statement )
|
||||
[
|
||||
"drop table " 0% 0% ";" 0% drop
|
||||
"drop table " 0% 0% drop
|
||||
] query-make ;
|
||||
|
||||
M: postgresql-db drop-sql-statement ( class -- seq )
|
||||
|
|
|
@ -1,9 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math namespaces sequences random
|
||||
strings
|
||||
math.bitfields.lib namespaces.lib db db.tuples db.types
|
||||
math.intervals ;
|
||||
strings math.parser math.intervals combinators
|
||||
math.bitfields.lib namespaces.lib db db.tuples db.types ;
|
||||
IN: db.queries
|
||||
|
||||
GENERIC: where ( specs obj -- )
|
||||
|
@ -15,7 +14,7 @@ GENERIC: where ( specs obj -- )
|
|||
|
||||
: query-make ( class quot -- )
|
||||
>r sql-props r>
|
||||
[ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
|
||||
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
|
||||
<simple-statement> maybe-make-retryable ; inline
|
||||
|
||||
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
|
||||
|
@ -127,3 +126,36 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
|
|||
" from " 0% 0%
|
||||
where-clause
|
||||
] query-make ;
|
||||
|
||||
: do-group ( tuple groups -- )
|
||||
[
|
||||
", " join " group by " prepend append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: do-order ( tuple order -- )
|
||||
[
|
||||
", " join " order by " prepend append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: do-offset ( tuple n -- )
|
||||
[
|
||||
number>string " offset " prepend append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: do-limit ( tuple n -- )
|
||||
[
|
||||
number>string " limit " prepend append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: make-advanced-statement ( tuple advanced -- tuple' )
|
||||
dupd
|
||||
{
|
||||
[ group>> [ do-group ] [ drop ] if* ]
|
||||
[ order>> [ do-order ] [ drop ] if* ]
|
||||
[ limit>> [ do-limit ] [ drop ] if* ]
|
||||
[ offset>> [ do-offset ] [ drop ] if* ]
|
||||
} 2cleave ;
|
||||
|
||||
M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
|
||||
advanced-statement boa
|
||||
[ <select-by-slots-statement> ] dip make-advanced-statement ;
|
||||
|
|
|
@ -4,9 +4,11 @@ IN: db.sql.tests
|
|||
! TUPLE: person name age ;
|
||||
: insert-1
|
||||
{ insert
|
||||
{ table "person" }
|
||||
{ columns "name" "age" }
|
||||
{ values "erg" 26 }
|
||||
{
|
||||
{ table "person" }
|
||||
{ columns "name" "age" }
|
||||
{ values "erg" 26 }
|
||||
}
|
||||
} ;
|
||||
|
||||
: update-1
|
||||
|
|
|
@ -4,24 +4,25 @@ USING: alien.c-types arrays assocs kernel math math.parser
|
|||
namespaces sequences db.sqlite.ffi db combinators
|
||||
continuations db.types calendar.format serialize
|
||||
io.streams.byte-array byte-arrays io.encodings.binary
|
||||
io.backend ;
|
||||
io.backend db.errors ;
|
||||
IN: db.sqlite.lib
|
||||
|
||||
: sqlite-error ( n -- * )
|
||||
sqlite-error-messages nth throw ;
|
||||
ERROR: sqlite-error < db-error n string ;
|
||||
ERROR: sqlite-sql-error < sql-error n string ;
|
||||
|
||||
: sqlite-statement-error-string ( -- str )
|
||||
db get db-handle sqlite3_errmsg ;
|
||||
: throw-sqlite-error ( n -- * )
|
||||
dup sqlite-error-messages nth sqlite-error ;
|
||||
|
||||
: sqlite-statement-error ( -- * )
|
||||
sqlite-statement-error-string throw ;
|
||||
SQLITE_ERROR
|
||||
db get db-handle sqlite3_errmsg sqlite-sql-error ;
|
||||
|
||||
: sqlite-check-result ( n -- )
|
||||
{
|
||||
{ [ dup SQLITE_OK = ] [ drop ] }
|
||||
{ [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
|
||||
[ sqlite-error ]
|
||||
} cond ;
|
||||
{ SQLITE_OK [ ] }
|
||||
{ SQLITE_ERROR [ sqlite-statement-error ] }
|
||||
[ throw-sqlite-error ]
|
||||
} case ;
|
||||
|
||||
: sqlite-open ( path -- db )
|
||||
normalize-path
|
||||
|
@ -158,12 +159,11 @@ IN: db.sqlite.lib
|
|||
dup sqlite-#columns [ sqlite-column ] with map ;
|
||||
|
||||
: sqlite-step-has-more-rows? ( prepared -- bool )
|
||||
dup SQLITE_ROW = [
|
||||
drop t
|
||||
] [
|
||||
dup SQLITE_DONE =
|
||||
[ drop ] [ sqlite-check-result ] if f
|
||||
] if ;
|
||||
{
|
||||
{ SQLITE_ROW [ t ] }
|
||||
{ SQLITE_DONE [ f ] }
|
||||
[ sqlite-check-result f ]
|
||||
} case ;
|
||||
|
||||
: sqlite-next ( prepared -- ? )
|
||||
sqlite3_step sqlite-step-has-more-rows? ;
|
||||
|
|
|
@ -16,7 +16,7 @@ M: sqlite-db make-db* ( path db -- db )
|
|||
swap >>path ;
|
||||
|
||||
M: sqlite-db db-open ( db -- db )
|
||||
[ path>> sqlite-open ] [ swap >>handle ] bi ;
|
||||
dup path>> sqlite-open >>handle ;
|
||||
|
||||
M: sqlite-db db-close ( handle -- ) sqlite-close ;
|
||||
M: sqlite-db dispose ( db -- ) dispose-db ;
|
||||
|
@ -197,4 +197,3 @@ M: sqlite-db compound ( str seq -- str' )
|
|||
{ "default" [ first number>string join-space ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
|
|
|
@ -3,7 +3,8 @@
|
|||
USING: io.files kernel tools.test db db.tuples classes
|
||||
db.types continuations namespaces math math.ranges
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitfields.lib ;
|
||||
db.postgresql accessors random math.bitfields.lib
|
||||
math.ranges strings sequences.lib ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
|
@ -198,9 +199,10 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
: test-sqlite ( quot -- )
|
||||
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
|
||||
|
||||
: test-postgresql ( -- )
|
||||
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
|
||||
! : test-postgresql ( quot -- )
|
||||
! >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
|
||||
|
||||
: test-postgresql drop ;
|
||||
: test-repeated-insert
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
[ ] [ person1 get insert-tuple ] unit-test
|
||||
|
@ -224,6 +226,12 @@ TUPLE: serialize-me id data ;
|
|||
|
||||
TUPLE: exam id name score ;
|
||||
|
||||
: random-exam ( -- exam )
|
||||
f
|
||||
6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
|
||||
100 random
|
||||
exam boa ;
|
||||
|
||||
: test-intervals ( -- )
|
||||
exam "EXAM"
|
||||
{
|
||||
|
@ -415,7 +423,7 @@ TUPLE: does-not-persist ;
|
|||
] test-postgresql
|
||||
|
||||
|
||||
TUPLE: suparclass a ;
|
||||
TUPLE: suparclass id a ;
|
||||
|
||||
suparclass f {
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
|
@ -428,8 +436,26 @@ subbclass "SUBCLASS" {
|
|||
{ "b" "B" TEXT }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: fubbclass < subbclass ;
|
||||
|
||||
fubbclass "FUBCLASS" { } define-persistent
|
||||
|
||||
: test-db-inheritance ( -- )
|
||||
[ ] [ subbclass ensure-table ] unit-test ;
|
||||
[ ] [ subbclass ensure-table ] unit-test
|
||||
[ ] [ fubbclass ensure-table ] unit-test
|
||||
|
||||
[ ] [
|
||||
subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
|
||||
] unit-test
|
||||
|
||||
[ t "hi" 5 ] [
|
||||
subbclass new "id" get >>id select-tuple
|
||||
[ subbclass? ] [ b>> ] [ a>> ] tri
|
||||
] 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
|
||||
|
||||
|
|
|
@ -13,10 +13,10 @@ IN: db.tuples
|
|||
"db-columns" set-word-prop
|
||||
"db-relations" set-word-prop ;
|
||||
|
||||
ERROR: not-persistent ;
|
||||
ERROR: not-persistent class ;
|
||||
|
||||
: db-table ( class -- obj )
|
||||
"db-table" word-prop [ not-persistent ] unless* ;
|
||||
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
|
||||
|
||||
: db-columns ( class -- obj )
|
||||
superclasses [ "db-columns" word-prop ] map concat ;
|
||||
|
@ -42,6 +42,8 @@ HOOK: <insert-user-assigned-statement> db ( class -- obj )
|
|||
HOOK: <update-tuple-statement> db ( class -- obj )
|
||||
HOOK: <delete-tuples-statement> db ( tuple class -- obj )
|
||||
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
|
||||
TUPLE: advanced-statement group order offset limit ;
|
||||
HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
|
||||
|
||||
HOOK: insert-tuple* db ( tuple statement -- )
|
||||
|
||||
|
@ -74,16 +76,16 @@ M: retryable execute-statement* ( statement type -- )
|
|||
[ regenerate-params bind-statement* f ] cleanup
|
||||
] curry 10 retry drop ;
|
||||
|
||||
: resulting-tuple ( row out-params -- tuple )
|
||||
dup first class>> new [
|
||||
: resulting-tuple ( class row out-params -- tuple )
|
||||
rot class new [
|
||||
[
|
||||
>r slot-name>> r> set-slot-named
|
||||
] curry 2each
|
||||
] keep ;
|
||||
|
||||
: query-tuples ( statement -- seq )
|
||||
: query-tuples ( exemplar-tuple statement -- seq )
|
||||
[ out-params>> ] keep query-results [
|
||||
[ sql-row-typed swap resulting-tuple ] with query-map
|
||||
[ sql-row-typed swap resulting-tuple ] with with query-map
|
||||
] with-disposal ;
|
||||
|
||||
: query-modify-tuple ( tuple statement -- )
|
||||
|
@ -141,9 +143,12 @@ M: retryable execute-statement* ( statement type -- )
|
|||
[ bind-tuple ] keep execute-statement
|
||||
] with-disposal ;
|
||||
|
||||
: select-tuples ( tuple -- tuples )
|
||||
dup dup class <select-by-slots-statement> [
|
||||
[ bind-tuple ] keep query-tuples
|
||||
] with-disposal ;
|
||||
: do-select ( exemplar-tuple statement -- tuples )
|
||||
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
|
||||
|
||||
: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;
|
||||
: select-tuples ( tuple -- tuples )
|
||||
dup dup class <select-by-slots-statement> do-select ;
|
||||
|
||||
: select-tuple ( tuple -- tuple/f )
|
||||
dup dup class f f f 1 <advanced-select-statement>
|
||||
do-select ?first ;
|
||||
|
|
|
@ -142,7 +142,8 @@ HOOK: bind% db ( spec -- )
|
|||
HOOK: bind# db ( spec obj -- )
|
||||
|
||||
: offset-of-slot ( str obj -- n )
|
||||
class "slots" word-prop slot-named slot-spec-offset ;
|
||||
class superclasses [ "slots" word-prop ] map concat
|
||||
slot-named slot-spec-offset ;
|
||||
|
||||
: get-slot-named ( name obj -- value )
|
||||
tuck offset-of-slot slot ;
|
||||
|
|
|
@ -64,9 +64,11 @@ M: winnt add-completion ( win32-handle -- )
|
|||
|
||||
: handle-overlapped ( timeout -- ? )
|
||||
wait-for-overlapped [
|
||||
>r drop GetLastError
|
||||
[ 1array ] [ expected-io-error? ] bi
|
||||
[ r> 2drop f ] [ r> resume-callback t ] if
|
||||
dup [
|
||||
>r drop GetLastError 1array r> resume-callback t
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] [
|
||||
resume-callback t
|
||||
] if ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -38,15 +38,15 @@ M: TLSv1 ssl-method drop TLSv1_method ;
|
|||
OpenSSL_add_all_digests
|
||||
OpenSSL_add_all_ciphers ;
|
||||
|
||||
SYMBOL: ssl-initiazed?
|
||||
SYMBOL: ssl-initialized?
|
||||
|
||||
: maybe-init-ssl ( -- )
|
||||
ssl-initiazed? get-global [
|
||||
ssl-initialized? get-global [
|
||||
init-ssl
|
||||
t ssl-initiazed? set-global
|
||||
t ssl-initialized? set-global
|
||||
] unless ;
|
||||
|
||||
[ f ssl-initiazed? set-global ] "openssl" add-init-hook
|
||||
[ f ssl-initialized? set-global ] "openssl" add-init-hook
|
||||
|
||||
TUPLE: openssl-context < secure-context aliens ;
|
||||
|
||||
|
|
|
@ -23,7 +23,7 @@ namespaces continuations layouts accessors ;
|
|||
[ ] [ "sudoku" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
cell 8 = 30 15 ? 100000 * small-enough?
|
||||
cell 8 = 20 10 ? 100000 * small-enough?
|
||||
] unit-test
|
||||
|
||||
[ ] [ "hello-ui" shake-and-bake ] unit-test
|
||||
|
@ -37,6 +37,12 @@ namespaces continuations layouts accessors ;
|
|||
cell 8 = 40 20 ? 100000 * small-enough?
|
||||
] unit-test
|
||||
|
||||
[ ] [ "maze" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
cell 8 = 30 15 ? 100000 * small-enough?
|
||||
] unit-test
|
||||
|
||||
[ ] [ "bunny" shake-and-bake ] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
|
@ -108,6 +108,8 @@ IN: tools.deploy.shaker
|
|||
|
||||
: stripped-globals ( -- seq )
|
||||
[
|
||||
"callbacks" "alien.compiler" lookup ,
|
||||
|
||||
{
|
||||
bootstrap.stage2:bootstrap-time
|
||||
continuations:error
|
||||
|
@ -142,6 +144,7 @@ IN: tools.deploy.shaker
|
|||
|
||||
{
|
||||
gensym
|
||||
name>char-hook
|
||||
classes:class-and-cache
|
||||
classes:class-not-cache
|
||||
classes:class-or-cache
|
||||
|
@ -167,6 +170,8 @@ IN: tools.deploy.shaker
|
|||
vocabs:load-vocab-hook
|
||||
word
|
||||
} %
|
||||
|
||||
{ } { "optimizer.math.partial" } strip-vocab-globals %
|
||||
] when
|
||||
|
||||
strip-prettyprint? [
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
|
|||
sequences math namespaces.private continuations.private
|
||||
concurrency.messaging quotations kernel.private words
|
||||
sequences.private assocs models arrays accessors
|
||||
generic generic.standard ;
|
||||
generic generic.standard definitions ;
|
||||
IN: tools.walker
|
||||
|
||||
SYMBOL: show-walker-hook ! ( status continuation thread -- )
|
||||
|
@ -73,6 +73,7 @@ M: object add-breakpoint ;
|
|||
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
||||
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
||||
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
|
||||
{ [ dup uses \ suspend swap member? ] [ execute break ] }
|
||||
{ [ dup primitive? ] [ execute break ] }
|
||||
[ word-def (step-into-quot) ]
|
||||
} cond ;
|
||||
|
@ -89,7 +90,6 @@ SYMBOL: step-into
|
|||
SYMBOL: step-all
|
||||
SYMBOL: step-into-all
|
||||
SYMBOL: step-back
|
||||
SYMBOL: detach
|
||||
SYMBOL: abandon
|
||||
SYMBOL: call-in
|
||||
|
||||
|
@ -137,7 +137,7 @@ SYMBOL: +stopped+
|
|||
{
|
||||
>n ndrop >c c>
|
||||
continue continue-with
|
||||
stop yield suspend sleep (spawn)
|
||||
stop suspend (spawn)
|
||||
} [
|
||||
dup [ execute break ] curry
|
||||
"step-into" set-word-prop
|
||||
|
@ -168,10 +168,7 @@ SYMBOL: +stopped+
|
|||
+running+ set-status ;
|
||||
|
||||
: walker-stopped ( -- )
|
||||
+stopped+ set-status
|
||||
[ status +stopped+ eq? ]
|
||||
[ [ drop f ] handle-synchronous ]
|
||||
[ ] while ;
|
||||
+stopped+ set-status ;
|
||||
|
||||
: step-into-all-loop ( -- )
|
||||
+running+ set-status
|
||||
|
|
|
@ -15,18 +15,22 @@ IN: webapps.pastebin
|
|||
! DOMAIN MODEL
|
||||
! ! !
|
||||
|
||||
TUPLE: paste id summary author mode date contents annotations ;
|
||||
TUPLE: entity id summary author mode date contents ;
|
||||
|
||||
\ paste "PASTE"
|
||||
entity f
|
||||
{
|
||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
|
||||
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
|
||||
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
|
||||
{ "date" "DATE" DATETIME +not-null+ , }
|
||||
{ "date" "DATE" DATETIME +not-null+ }
|
||||
{ "contents" "CONTENTS" TEXT +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: paste < entity annotations ;
|
||||
|
||||
\ paste "PASTES" { } define-persistent
|
||||
|
||||
: <paste> ( id -- paste )
|
||||
\ paste new
|
||||
swap >>id ;
|
||||
|
@ -34,23 +38,17 @@ TUPLE: paste id summary author mode date contents annotations ;
|
|||
: pastes ( -- pastes )
|
||||
f <paste> select-tuples ;
|
||||
|
||||
TUPLE: annotation aid id summary author mode contents date ;
|
||||
TUPLE: annotation < entity parent ;
|
||||
|
||||
annotation "ANNOTATION"
|
||||
annotation "ANNOTATIONS"
|
||||
{
|
||||
{ "aid" "AID" INTEGER +db-assigned-id+ }
|
||||
{ "id" "ID" INTEGER +not-null+ }
|
||||
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
|
||||
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
|
||||
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
|
||||
{ "date" "DATE" DATETIME +not-null+ }
|
||||
{ "contents" "CONTENTS" TEXT +not-null+ }
|
||||
{ "parent" "PARENT" INTEGER +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: <annotation> ( id aid -- annotation )
|
||||
: <annotation> ( parent id -- annotation )
|
||||
annotation new
|
||||
swap >>aid
|
||||
swap >>id ;
|
||||
swap >>id
|
||||
swap >>parent ;
|
||||
|
||||
: fetch-annotations ( paste -- paste )
|
||||
dup annotations>> [
|
||||
|
@ -76,8 +74,8 @@ M: paste entity-link
|
|||
id>> "id" associate "$pastebin/paste" swap link>string ;
|
||||
|
||||
M: annotation entity-link
|
||||
[ id>> "id" associate "$pastebin/paste" swap link>string ]
|
||||
[ aid>> number>string "#" prepend ] bi
|
||||
[ parent>> "parent" associate "$pastebin/paste" swap link>string ]
|
||||
[ id>> number>string "#" prepend ] bi
|
||||
append ;
|
||||
|
||||
: pastebin-template ( name -- template )
|
||||
|
@ -147,7 +145,7 @@ M: annotation entity-link
|
|||
[ validate-integer-id ] >>init
|
||||
[ "id" value paste annotations>> paste-feed ] >>feed ;
|
||||
|
||||
: validate-paste ( -- )
|
||||
: validate-entity ( -- )
|
||||
{
|
||||
{ "summary" [ v-one-line ] }
|
||||
{ "author" [ v-one-line ] }
|
||||
|
@ -156,7 +154,7 @@ M: annotation entity-link
|
|||
{ "captcha" [ v-captcha ] }
|
||||
} validate-params ;
|
||||
|
||||
: deposit-paste-slots ( tuple -- )
|
||||
: deposit-entity-slots ( tuple -- )
|
||||
now >>date
|
||||
{ "summary" "author" "mode" "contents" } deposit-slots ;
|
||||
|
||||
|
@ -170,10 +168,10 @@ M: annotation entity-link
|
|||
"new-paste" pastebin-template >>template
|
||||
|
||||
[
|
||||
validate-paste
|
||||
validate-entity
|
||||
|
||||
f <paste>
|
||||
[ deposit-paste-slots ]
|
||||
[ deposit-entity-slots ]
|
||||
[ insert-tuple ]
|
||||
[ id>> "$pastebin/paste" <id-redirect> ]
|
||||
tri
|
||||
|
@ -195,31 +193,35 @@ M: annotation entity-link
|
|||
|
||||
: <new-annotation-action> ( -- action )
|
||||
<page-action>
|
||||
[ validate-paste ] >>validate
|
||||
|
||||
[ "id" param "$pastebin/paste" <id-redirect> ] >>display
|
||||
[
|
||||
{ { "id" [ v-integer ] } } validate-params
|
||||
"id" value "$pastebin/paste" <id-redirect>
|
||||
] >>display
|
||||
|
||||
[
|
||||
f f <annotation>
|
||||
{
|
||||
[ deposit-paste-slots ]
|
||||
[ { "id" } deposit-slots ]
|
||||
[ insert-tuple ]
|
||||
[
|
||||
! Add anchor here
|
||||
id>> "$pastebin/paste" <id-redirect>
|
||||
]
|
||||
} cleave
|
||||
{ { "id" [ v-integer ] } } validate-params
|
||||
validate-entity
|
||||
] >>validate
|
||||
|
||||
[
|
||||
"id" value f <annotation>
|
||||
[ deposit-entity-slots ]
|
||||
[ insert-tuple ]
|
||||
[
|
||||
! Add anchor here
|
||||
parent>> "$pastebin/paste" <id-redirect>
|
||||
]
|
||||
tri
|
||||
] >>submit ;
|
||||
|
||||
: <delete-annotation-action> ( -- action )
|
||||
<action>
|
||||
[ { { "aid" [ v-number ] } } validate-params ] >>validate
|
||||
[ { { "id" [ v-number ] } } validate-params ] >>validate
|
||||
|
||||
[
|
||||
f "aid" value <annotation> select-tuple
|
||||
f "id" value <annotation> select-tuple
|
||||
[ delete-tuples ]
|
||||
[ id>> "$pastebin/paste" <id-redirect> ]
|
||||
[ parent>> "$pastebin/paste" <id-redirect> ]
|
||||
bi
|
||||
] >>submit ;
|
||||
|
||||
|
|
|
@ -11,11 +11,12 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
|
|||
CELL code = array_nth(quadruple,0);
|
||||
REGISTER_ROOT(code);
|
||||
|
||||
CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2))
|
||||
| (to_fixnum(array_nth(quadruple,1)) << 8));
|
||||
CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
|
||||
F_REL rel;
|
||||
rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8);
|
||||
rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format();
|
||||
|
||||
CELL relocation = allot_array_2(rel_type,rel_offset);
|
||||
F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
|
||||
memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL));
|
||||
|
||||
UNREGISTER_ROOT(code);
|
||||
UNREGISTER_ROOT(literals);
|
||||
|
@ -24,7 +25,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
|
|||
WORD_TYPE,
|
||||
untag_object(code),
|
||||
NULL, /* no labels */
|
||||
untag_object(relocation),
|
||||
tag_object(relocation),
|
||||
untag_object(literals));
|
||||
}
|
||||
|
||||
|
|
Loading…
Reference in New Issue