steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Eduardo Cavazos 2008-05-31 07:30:45 -05:00
parent b440a63406 a52ec223d8
commit ef9a59c51f
22 changed files with 246 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
core/alien/compiler/compiler.factor
View File

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

2
core/alien/structs/structs-docs.factor
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: } "." ;

5
core/generator/fixup/fixup-docs.factor
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" } }

6
extra/bunny/model/model.factor
View File

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

11
extra/db/errors/errors.factor Normal file
View 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 ;

2
extra/db/postgresql/postgresql.factor
View File

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

40
extra/db/queries/queries.factor
View File

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

8
extra/db/sql/sql-tests.factor
View File

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

32
extra/db/sqlite/lib/lib.factor
View File

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

3
extra/db/sqlite/sqlite.factor
View File

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

36
extra/db/tuples/tuples-tests.factor
View File

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

27
extra/db/tuples/tuples.factor
View File

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

3
extra/db/types/types.factor
View File

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

8
extra/io/windows/nt/backend/backend.factor
View File

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

24
extra/logging/logging-tests.factor Normal file
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

55
extra/logging/logging.factor
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

8
extra/openssl/openssl.factor
View File

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

8
extra/tools/deploy/deploy-tests.factor
View File

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

5
extra/tools/deploy/shaker/shaker.factor
View File

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

11
extra/tools/walker/walker.factor
View File

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

76
extra/webapps/pastebin/pastebin.factor
View File

@ -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
vm/profiler.c
View File

@ -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));
}