diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 08b52367b0..67665b4d7e 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -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 ] curry + xt>> [ [ register-callback ] [ word-xt drop ] 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 diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index e7e576293f..baf0b40707 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -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 } " or " { $link malloc-object } "." +"C union objects can be allocated by calling " { $link } " or " { $link malloc-object } "." $nl "Arrays of C unions can be created by calling " { $link } " 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: } "." ; diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index 58bc32397f..64d733ef8c 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -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" } } diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 2dac9eb688..8fef44a76a 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -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 ; diff --git a/extra/db/errors/errors.factor b/extra/db/errors/errors.factor new file mode 100644 index 0000000000..1e0d1e7fb4 --- /dev/null +++ b/extra/db/errors/errors.factor @@ -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 ; diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 3e81b264d6..f55897db88 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -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 ) diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 6dab4f80b8..9743e87f2e 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -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 maybe-make-retryable ; inline M: db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -127,3 +126,36 @@ M: db ( 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 ( tuple class group order limit offset -- tuple ) + advanced-statement boa + [ ] dip make-advanced-statement ; diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index cab7b83ced..0b57c2d8fa 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -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 diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e92c4bbd8a..b652e8fed7 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -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? ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c10775f1c9..cc4e4d116a 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -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 ; - diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index b7c6fce933..e4a16d0b16 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -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 diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0ffbd5bd47..0a69b9cde8 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -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: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) +TUPLE: advanced-statement group order offset limit ; +HOOK: 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 [ - [ 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 do-select ; + +: select-tuple ( tuple -- tuple/f ) + dup dup class f f f 1 + do-select ?first ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 8dbf6786bc..03e6b15bdb 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -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 ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 993aff5200..1a7462f304 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -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 ; diff --git a/extra/logging/logging-tests.factor b/extra/logging/logging-tests.factor new file mode 100644 index 0000000000..796c8769fc --- /dev/null +++ b/extra/logging/logging-tests.factor @@ -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 diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index f54ab05bbd..df03bf320b 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -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 append >quotation ; +: stack-balancer ( effect -- quot ) + [ in>> length [ ndrop ] curry ] + [ out>> length f >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 diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index ca5a4e8846..03343820db 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -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 ; diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 37689f749f..8ff22fb1ad 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -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 ] [ diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 4f0d6ac036..e8675f5891 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -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? [ diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index ef6dac66f6..2417e7ac39 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -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 diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 9852bf47cb..43cae74ec8 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -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 + : ( id -- paste ) \ paste new swap >>id ; @@ -34,23 +38,17 @@ TUPLE: paste id summary author mode date contents annotations ; : pastes ( -- pastes ) f 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 -: ( id aid -- 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 - [ deposit-paste-slots ] + [ deposit-entity-slots ] [ insert-tuple ] [ id>> "$pastebin/paste" ] tri @@ -195,31 +193,35 @@ M: annotation entity-link : ( -- action ) - [ validate-paste ] >>validate - - [ "id" param "$pastebin/paste" ] >>display + [ + { { "id" [ v-integer ] } } validate-params + "id" value "$pastebin/paste" + ] >>display [ - f f - { - [ deposit-paste-slots ] - [ { "id" } deposit-slots ] - [ insert-tuple ] - [ - ! Add anchor here - id>> "$pastebin/paste" - ] - } cleave + { { "id" [ v-integer ] } } validate-params + validate-entity + ] >>validate + + [ + "id" value f + [ deposit-entity-slots ] + [ insert-tuple ] + [ + ! Add anchor here + parent>> "$pastebin/paste" + ] + tri ] >>submit ; : ( -- action ) - [ { { "aid" [ v-number ] } } validate-params ] >>validate + [ { { "id" [ v-number ] } } validate-params ] >>validate [ - f "aid" value select-tuple + f "id" value select-tuple [ delete-tuples ] - [ id>> "$pastebin/paste" ] + [ parent>> "$pastebin/paste" ] bi ] >>submit ; diff --git a/vm/profiler.c b/vm/profiler.c index 08bb846c85..58a4aa035e 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -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)); }