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

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

db4
Daniel Ehrenberg 2008-06-01 01:24:19 -05:00
parent b88a383151 7eca88cdb5
commit a4acf8907c
65 changed files with 1202 additions and 491 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: } "." ;

4
core/combinators/combinators-docs.factor
View File

@ -10,8 +10,10 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
{ $subsection alist>quot } ;
ARTICLE: "combinators" "Additional combinators"
"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary."
"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
$nl
"A looping combinator:"
{ $subsection while }
"Generalization of " { $link bi } " and " { $link tri } ":"
{ $subsection cleave }
"Generalization of " { $link bi* } " and " { $link tri* } ":"

7
core/generator/fixup/fixup-docs.factor
View File

@ -1,14 +1,11 @@
USING: help.syntax help.markup generator.fixup math kernel
USING: help.syntax help.markup math kernel
words strings alien ;
IN: generator.fixup
HELP: frame-required
{ $values { "n" "a non-negative integer" } }
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
HELP: (rel-fixup)
{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } }
{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ;
HELP: add-literal
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;

32
core/generator/fixup/fixup.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces sequences words
quotations strings alien.strings layouts system combinators
math.bitfields words.private cpu.architecture math.order ;
quotations strings alien.accessors alien.strings layouts system
combinators math.bitfields words.private cpu.architecture
math.order accessors growable ;
IN: generator.fixup
: no-stack-frame -1 ; inline
@ -77,26 +78,23 @@ TUPLE: label-fixup label class ;
: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
dup label-fixup-class rc-absolute?
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
dup label-fixup-label swap label-fixup-class
compiled-offset 4 - rot 3array label-table get push ;
dup label>> swap class>> compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: (rel-fixup) ( arg class type offset -- pair )
pick rc-absolute-cell = cell 4 ? -
>r { 0 8 16 } bitfield r>
2array ;
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
dup rel-fixup-arg
over rel-fixup-class
rot rel-fixup-type
compiled-offset (rel-fixup)
relocation-table get push-all ;
[ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
@ -134,7 +132,7 @@ SYMBOL: literal-table
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
V{ } clone relocation-table set
BV{ } clone relocation-table set
V{ } clone label-table set ;
: resolve-labels ( labels -- labels' )
@ -150,6 +148,6 @@ SYMBOL: literal-table
dup stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >array
relocation-table get >byte-array
label-table get resolve-labels
] { } make ;

8
core/io/binary/binary-docs.factor
View File

@ -1,8 +1,8 @@
USING: help.markup help.syntax io math ;
USING: help.markup help.syntax io math byte-arrays ;
IN: io.binary
ARTICLE: "stream-binary" "Working with binary data"
"The core stream words read and write strings. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
"Stream words on binary streams only read and write byte arrays. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
$nl
"There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around."
$nl
@ -42,11 +42,11 @@ HELP: nth-byte
{ $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ;
HELP: >le
{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: >be
{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: mask-byte

4
core/io/binary/binary.factor
View File

@ -10,8 +10,8 @@ IN: io.binary
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ;
: >be ( x n -- str ) >le dup reverse-here ;
: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ;
: >be ( x n -- byte-array ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )
dup HEX: ffffffff bitand

5
core/kernel/kernel-docs.factor
View File

@ -193,10 +193,7 @@ ARTICLE: "implementing-combinators" "Implementing combinators"
": keep ( x quot -- x )"
" over >r call r> ; inline"
}
"Word inlining is documented in " { $link "declarations" } "."
$nl
"A looping combinator:"
{ $subsection while } ;
"Word inlining is documented in " { $link "declarations" } "." ;
ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."

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 ;

70
extra/cairo/gadgets/gadgets.factor
View File

@ -1,73 +1,39 @@
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: cairo cairo.ffi ui.render kernel opengl.gl opengl
math byte-arrays ui.gadgets accessors arrays
namespaces io.backend ;
USING: sequences math opengl.gadgets kernel
byte-arrays cairo.ffi cairo io.backend
opengl.gl arrays ;
IN: cairo.gadgets
! We need two kinds of gadgets:
! one performs the cairo ops once and caches the bytes, the other
! performs cairo ops every refresh
TUPLE: cairo-gadget width height quot cache? bytes ;
PREDICATE: cached-cairo < cairo-gadget cache?>> ;
: <cairo-gadget> ( width height quot -- cairo-gadget )
cairo-gadget construct-gadget
swap >>quot
swap >>height
swap >>width ;
: <cached-cairo> ( width height quot -- cairo-gadget )
<cairo-gadget> t >>cache? ;
: width>stride ( width -- stride ) 4 * ;
: copy-cairo ( width height quot -- byte-array )
>r over width>stride
: copy-cairo ( dim quot -- byte-array )
>r first2 over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
r> with-cairo-from-surface ;
: (cairo>bytes) ( gadget -- byte-array )
[ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
: <cairo-gadget> ( dim quot -- )
over 2^-bounds swap copy-cairo
GL_BGRA rot <texture-gadget> ;
GENERIC: cairo>bytes
M: cairo-gadget cairo>bytes ( gadget -- byte-array )
(cairo>bytes) ;
M: cached-cairo cairo>bytes ( gadget -- byte-array )
dup bytes>> [ ] [
dup (cairo>bytes) [ >>bytes drop ] keep
] ?if ;
: cairo>png ( gadget path -- )
>r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
[ height>> ] tri over width>stride
cairo_image_surface_create_for_data
r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
M: cairo-gadget draw-gadget* ( gadget -- )
origin get [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
[ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
[ cairo>bytes ] tri glDrawPixels
] with-translation ;
M: cairo-gadget pref-dim* ( gadget -- rect )
[ width>> ] [ height>> ] bi 2array ;
! maybe also texture>png
! : cairo>png ( gadget path -- )
! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
! [ height>> ] tri over width>stride
! cairo_image_surface_create_for_data
! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
: copy-surface ( surface -- )
cr swap 0 0 cairo_set_source_surface
cr cairo_paint ;
: <bytes-gadget> ( width height bytes -- cairo-gadget )
>r [ ] <cached-cairo> r> >>bytes ;
: <png-gadget> ( path -- gadget )
normalize-path cairo_image_surface_create_from_png
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height 2dup ]
[ cairo_image_surface_get_height 2array dup 2^-bounds ]
[ [ copy-surface ] curry copy-cairo ] tri
<bytes-gadget> ;
GL_BGRA rot <texture-gadget> ;

20
extra/cairo/pango/gadgets/gadgets.factor
View File

@ -1,20 +0,0 @@
USING: cairo.pango cairo cairo.ffi cairo.gadgets
alien.c-types kernel math ;
IN: cairo.pango.gadgets
: (pango-gadget) ( setup show -- gadget )
[ drop layout-size ]
[ compose [ with-pango ] curry <cached-cairo> ] 2bi ;
: <pango-gadget> ( quot -- gadget )
[ cr layout pango_cairo_show_layout ] (pango-gadget) ;
USING: prettyprint sequences ui.gadgets.panes ;
: hello-pango ( -- )
50 [ 6 + ] map [
"Sans Bold " swap unparse append
[ layout-font "Hello, Pango!" layout-text ] curry
<pango-gadget> gadget.
] each ;
MAIN: hello-pango

4
extra/cairo/samples/samples.factor
View File

@ -142,6 +142,6 @@ IN: cairo.samples
USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
: samples ( -- )
{ arc clip clip-image dash gradient text utf8 }
[ 256 256 rot 1quotation <cached-cairo> gadget. ] each ;
[ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
MAIN: samples
MAIN: samples

25
extra/db/db.factor
View File

@ -39,31 +39,13 @@ TUPLE: statement handle sql in-params out-params bind-params bound? type ;
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
SINGLETON: throwable
SINGLETON: nonthrowable
: make-throwable ( obj -- obj' )
dup sequence? [
[ make-throwable ] map
] [
throwable >>type
] if ;
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
] [
nonthrowable >>type
] if ;
TUPLE: result-set sql in-params out-params handle n max ;
: construct-statement ( sql in out class -- statement )
new
swap >>out-params
swap >>in-params
swap >>sql
throwable >>type ;
swap >>sql ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
@ -81,12 +63,9 @@ GENERIC: more-rows? ( result-set -- ? )
GENERIC: execute-statement* ( statement type -- )
M: throwable execute-statement* ( statement type -- )
M: object execute-statement* ( statement type -- )
drop query-results dispose ;
M: nonthrowable execute-statement* ( statement type -- )
drop [ query-results dispose ] [ 2drop ] recover ;
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each

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 )

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

@ -1,21 +1,19 @@
! 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 -- )
: maybe-make-retryable ( statement -- statement )
dup in-params>> [ generator-bind? ] contains? [
make-retryable
] when ;
dup in-params>> [ generator-bind? ] contains?
[ make-retryable ] when ;
: 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 +125,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 ;

35
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,8 +199,8 @@ 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-repeated-insert
[ ] [ person ensure-table ] unit-test
@ -224,6 +225,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 +422,7 @@ TUPLE: does-not-persist ;
] test-postgresql
TUPLE: suparclass a ;
TUPLE: suparclass id a ;
suparclass f {
{ "id" "ID" +db-assigned-id+ }
@ -428,8 +435,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

31
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 -- )
@ -110,8 +112,8 @@ M: retryable execute-statement* ( statement type -- )
: recreate-table ( class -- )
[
drop-sql-statement make-nonthrowable
[ execute-statement ] with-disposals
[ drop-sql-statement [ execute-statement ] with-disposals
] curry ignore-errors
] [ create-table ] bi ;
: ensure-table ( class -- )
@ -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 ;

2
extra/dns/cache/cache.factor vendored
View File

@ -80,7 +80,7 @@ SYMBOL: NX
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ERROR: name-error name ;
! ERROR: name-error name ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

13
extra/dns/dns.factor
View File

@ -476,3 +476,16 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: message-query ( message -- query ) question-section>> 1st ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ERROR: name-error name ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fully-qualified ( name -- name )
{
{ [ dup empty? ] [ "." append ] }
{ [ dup peek CHAR: . = ] [ ] }
{ [ t ] [ "." append ] }
}
cond ;

91
extra/dns/forwarding/forwarding.factor Normal file
View File

@ -0,0 +1,91 @@
USING: kernel
combinators
vectors
io.sockets
accessors
newfx
dns dns.cache ;
IN: dns.forwarding
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DNS server - caching, forwarding
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (socket) ( -- vec ) V{ f } ;
: socket ( -- socket ) (socket) 1st ;
: init-socket ( -- ) f 5353 <inet4> <datagram> 0 (socket) as-mutate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (upstream-server) ( -- vec ) V{ f } ;
: upstream-server ( -- ip ) (upstream-server) 1st ;
: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->answer/cache ( query -- rrs/NX/f )
{
{ [ dup type>> CNAME = ] [ cache-get* ] }
{
[ dup clone CNAME >>type cache-get* vector? ]
[
dup clone CNAME >>type cache-get* 1st ! query rr/cname
dup rdata>> ! query rr/cname cname
>r swap clone r> ! rr/cname query cname
>>name ! rr/cname query
query->answer/cache ! rr/cname rrs/NX/f
{
{ [ dup vector? ] [ clone push-on ] }
{ [ dup NX = ] [ nip ] }
{ [ dup f = ] [ nip ] }
}
cond
]
}
{ [ t ] [ cache-get* ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: answer-from-cache ( message -- message/f )
dup message-query ! message query
dup query->answer/cache ! message query rrs/NX/f
{
{ [ dup f = ] [ 3drop f ] }
{ [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] }
{ [ t ] [ nip >>answer-section ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: answer-from-server ( message -- message )
upstream-server ask-server
cache-message ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: find-answer ( message -- message )
dup answer-from-cache dup
[ nip ]
[ drop answer-from-server ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: loop ( -- )
socket receive ! byte-array addr-spec
swap ! addr-spec byte-array
parse-message ! addr-spec message
find-answer ! addr-spec message
message->ba ! addr-spec byte-array
swap ! byte-array addr-spec
socket send
loop ;

59
extra/dns/resolver/resolver.factor
View File

@ -6,34 +6,6 @@ IN: dns.resolver
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Need to cache records even in the case of name error
: cache-message ( message -- message )
dup dup rcode>> NAME-ERROR =
[
[ question-section>> 1st ]
[ authority-section>> [ type>> SOA = ] filter random ttl>> ]
bi
cache-nx
]
[
{
[ answer-section>> cache-add-rrs ]
[ authority-section>> cache-add-rrs ]
[ additional-section>> cache-add-rrs ]
}
cleave
]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Ask and cache the records
: ask* ( message -- message ) ask cache-message ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/cache ( name -- name )
dup CNAME IN query boa cache-get dup vector? ! name result ?
[ nip 1st rdata>> ]
@ -43,26 +15,17 @@ IN: dns.resolver
: name->ip/cache ( name -- ip )
canonical/cache
dup A IN query boa cache-get ! name result
{
{
[ dup NX = ]
[ 2drop f ]
{ [ dup NX = ] [ 2drop f ] }
{ [ dup f = ] [ 2drop f ] }
{ [ t ] [ nip random rdata>> ] }
}
{
[ dup f = ]
[ 2drop f ]
}
{
[ t ]
[ nip random rdata>> ]
}
}
cond ;
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/server ( name -- name )
dup CNAME IN query boa query->message ask* answer-section>>
dup CNAME IN query boa query->message ask cache-message answer-section>>
[ type>> CNAME = ] filter dup empty? not
[ nip 1st rdata>> ]
[ drop ]
@ -70,7 +33,7 @@ IN: dns.resolver
: name->ip/server ( name -- ip )
canonical/server
dup A IN query boa query->message ask* answer-section>>
dup A IN query boa query->message ask cache-message answer-section>>
[ type>> A = ] filter dup empty? not
[ nip random rdata>> ]
[ 2drop f ]
@ -78,16 +41,6 @@ IN: dns.resolver
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fully-qualified ( name -- name )
{
{ [ dup empty? ] [ "." append ] }
{ [ dup peek CHAR: . = ] [ ] }
{ [ t ] [ "." append ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->ip ( name -- ip )
fully-qualified
dup name->ip/cache dup

20
extra/dns/stub/stub.factor Normal file
View File

@ -0,0 +1,20 @@
USING: kernel sequences random accessors dns ;
IN: dns.stub
! Stub resolver
!
! Generally useful, but particularly when running a forwarding,
! caching, nameserver on localhost with multiple Factor instances
! querying it.
: name->ip ( name -- ip )
A IN query boa
query->message
ask
dup rcode>> NAME-ERROR =
[ message-query name>> name-error ]
[ answer-section>> [ type>> A = ] filter random rdata>> ]
if ;

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 ;

43
extra/json/reader/reader-tests.factor Normal file
View File

@ -0,0 +1,43 @@
USING: arrays json.reader kernel multiline strings tools.test ;
IN: json.reader.tests
{ f } [ "false" json> ] unit-test
{ t } [ "true" json> ] unit-test
{ json-null } [ "null" json> ] unit-test
{ 0 } [ "0" json> ] unit-test
{ 102 } [ "102" json> ] unit-test
{ -102 } [ "-102" json> ] unit-test
{ 102 } [ "+102" json> ] unit-test
{ 102.0 } [ "102.0" json> ] unit-test
{ 102.5 } [ "102.5" json> ] unit-test
{ 102.5 } [ "102.50" json> ] unit-test
{ -10250 } [ "-102.5e2" json> ] unit-test
{ -10250 } [ "-102.5E+2" json> ] unit-test
{ 10.25 } [ "1025e-2" json> ] unit-test
{ 0.125 } [ "0.125" json> ] unit-test
{ -0.125 } [ "-0.125" json> ] unit-test
{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test
{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
{ H{
{ "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
{ "prime" { 2 3 5 7 11 13 } }
} } [ <" {
"fib": [1, 1, 2, 3, 5, 8,
{ "etc":"etc" } ],
"prime":
[ 2,3, 5,7,
11,
13
] }
"> json> ] unit-test
{ 0 } [ " 0" json> ] unit-test
{ 0 } [ "0 " json> ] unit-test
{ 0 } [ " 0 " json> ] unit-test

47
extra/json/reader/reader.factor
View File

@ -7,6 +7,8 @@ IN: json.reader
! Grammar for JSON from RFC 4627
SYMBOL: json-null
: [<&>] ( quot -- quot )
{ } make unclip [ <&> ] reduce ;
@ -17,8 +19,7 @@ LAZY: 'ws' ( -- parser )
" " token
"\n" token <|>
"\r" token <|>
"\t" token <|>
"" token <|> ;
"\t" token <|> <*> ;
LAZY: spaced ( parser -- parser )
'ws' swap &> 'ws' <& ;
@ -42,24 +43,39 @@ LAZY: 'value-separator' ( -- parser )
"," token spaced ;
LAZY: 'false' ( -- parser )
"false" token ;
"false" token [ drop f ] <@ ;
LAZY: 'null' ( -- parser )
"null" token ;
"null" token [ drop json-null ] <@ ;
LAZY: 'true' ( -- parser )
"true" token ;
"true" token [ drop t ] <@ ;
LAZY: 'quot' ( -- parser )
"\"" token ;
LAZY: 'hex-digit' ( -- parser )
[ digit> ] satisfy [ digit> ] <@ ;
: hex-digits>ch ( digits -- ch )
0 [ swap 16 * + ] reduce ;
LAZY: 'string-char' ( -- parser )
[ quotable? ] satisfy
"\\b" token [ drop 8 ] <@ <|>
"\\t" token [ drop CHAR: \t ] <@ <|>
"\\n" token [ drop CHAR: \n ] <@ <|>
"\\f" token [ drop 12 ] <@ <|>
"\\r" token [ drop CHAR: \r ] <@ <|>
"\\\"" token [ drop CHAR: " ] <@ <|>
"\\/" token [ drop CHAR: / ] <@ <|>
"\\\\" token [ drop CHAR: \\ ] <@ <|>
"\\u" token 'hex-digit' 4 exactly-n &>
[ hex-digits>ch ] <@ <|> ;
LAZY: 'string' ( -- parser )
'quot'
[
[ quotable? ] keep
[ CHAR: \\ = or ] keep
CHAR: " = not and
] satisfy <*> &>
'string-char' <*> &>
'quot' <& [ >string ] <@ ;
DEFER: 'value'
@ -86,6 +102,9 @@ LAZY: 'minus' ( -- parser )
LAZY: 'plus' ( -- parser )
"+" token ;
LAZY: 'sign' ( -- parser )
'minus' 'plus' <|> ;
LAZY: 'zero' ( -- parser )
"0" token [ drop 0 ] <@ ;
@ -116,11 +135,11 @@ LAZY: 'e' ( -- parser )
: sign-number ( pair -- number )
#! Pair is { minus? num }
#! Convert the json number value to a factor number
dup second swap first [ -1 * ] when ;
dup second swap first [ first "-" = [ -1 * ] when ] when* ;
LAZY: 'exp' ( -- parser )
'e'
'minus' 'plus' <|> <?> &>
'sign' <?> &>
'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ;
: sequence>frac ( seq -- num )
@ -136,7 +155,7 @@ LAZY: 'frac' ( -- parser )
dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
LAZY: 'number' ( -- parser )
'minus' <?>
'sign' <?>
[ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
@ -149,7 +168,7 @@ LAZY: 'value' ( -- parser )
'object' ,
'array' ,
'number' ,
] [<|>] ;
] [<|>] spaced ;
: json> ( string -- object )
#! Parse a json formatted string to a factor object

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

3
extra/memoize/memoize.factor
View File

@ -58,3 +58,6 @@ M: memoized reset-word
: reset-memoized ( word -- )
"memoize" word-prop clear-assoc ;
: invalidate-memoized ! ( inputs... word )
[ #in packer call ] [ "memoize" word-prop delete-at ] bi ;

8
extra/namespaces/lib/lib.factor
View File

@ -2,7 +2,7 @@
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
assocs.lib math.parser math sequences.lib locals ;
assocs.lib math.parser math sequences.lib locals mirrors ;
IN: namespaces.lib
@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- )
] with-scope
]
] ;
: make-object ( quot class -- object )
new [ <mirror> swap bind ] keep ; inline
: with-object ( object quot -- )
[ <mirror> ] dip bind ; inline

72
extra/opengl/gadgets/gadgets.factor Normal file
View File

@ -0,0 +1,72 @@
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: locals math.functions math namespaces
opengl.gl accessors kernel opengl ui.gadgets
destructors sequences ui.render colors ;
IN: opengl.gadgets
TUPLE: texture-gadget bytes format dim tex ;
: 2^-ceil ( x -- y )
dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
: 2^-bounds ( dim -- dim' )
[ 2^-ceil ] map ; foldable flushable
: <texture-gadget> ( bytes format dim -- gadget )
texture-gadget construct-gadget
swap >>dim
swap >>format
swap >>bytes ;
:: render ( gadget -- )
GL_ENABLE_BIT [
GL_TEXTURE_2D glEnable
GL_TEXTURE_2D gadget tex>> glBindTexture
GL_TEXTURE_2D
0
GL_RGBA
gadget dim>> 2^-bounds first2
0
gadget format>>
GL_UNSIGNED_BYTE
gadget bytes>>
glTexImage2D
init-texture
GL_TEXTURE_2D 0 glBindTexture
] do-attribs ;
:: four-corners ( dim -- )
[let* | w [ dim first ]
h [ dim second ]
dim' [ dim dup 2^-bounds [ /f ] 2map ]
w' [ dim' first ]
h' [ dim' second ] |
0 0 glTexCoord2d 0 0 glVertex2d
0 h' glTexCoord2d 0 h glVertex2d
w' h' glTexCoord2d w h glVertex2d
w' 0 glTexCoord2d w 0 glVertex2d
] ;
M: texture-gadget draw-gadget* ( gadget -- )
origin get [
GL_ENABLE_BIT [
white gl-color
1.0 -1.0 glPixelZoom
GL_TEXTURE_2D glEnable
GL_TEXTURE_2D over tex>> glBindTexture
GL_QUADS [
dim>> four-corners
] do-state
GL_TEXTURE_2D 0 glBindTexture
] do-attribs
] with-translation ;
M: texture-gadget graft* ( gadget -- )
gen-texture >>tex [ render ]
[ f >>bytes f >>format drop ] bi ;
M: texture-gadget ungraft* ( gadget -- )
tex>> delete-texture ;
M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ;

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 ;

60
extra/cairo/pango/pango.factor → extra/pango/cairo/cairo.factor
View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
!
! pangocairo bindings, from pango/pangocairo.h
USING: cairo.ffi alien.c-types math
alien.syntax system combinators alien ;
IN: cairo.pango
alien.syntax system combinators alien
arrays pango pango.fonts ;
IN: pango.cairo
<< "pangocairo" {
! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
@ -15,10 +15,6 @@ IN: cairo.pango
LIBRARY: pangocairo
TYPEDEF: void* PangoCairoFont
TYPEDEF: void* PangoCairoFontMap
TYPEDEF: void* PangoFontMap
FUNCTION: PangoFontMap*
pango_cairo_font_map_new ( ) ;
@ -92,49 +88,6 @@ pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ;
FUNCTION: void
pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Helpful functions from other parts of pango
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: PANGO_SCALE 1024 ;
FUNCTION: void
pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
FUNCTION: char*
pango_layout_get_text ( PangoLayout* layout ) ;
FUNCTION: void
pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ;
TYPEDEF: void* PangoFontDescription
FUNCTION: PangoFontDescription*
pango_font_description_from_string ( char* str ) ;
FUNCTION: char*
pango_font_description_to_string ( PangoFontDescription* desc ) ;
FUNCTION: char*
pango_font_description_to_filename ( PangoFontDescription* desc ) ;
FUNCTION: void
pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ;
FUNCTION: PangoFontDescription*
pango_layout_get_font_description ( PangoLayout* layout ) ;
FUNCTION: void
pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ;
FUNCTION: void
pango_font_description_free ( PangoFontDescription* desc ) ;
TYPEDEF: void* gpointer
FUNCTION: void
g_object_unref ( gpointer object ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Higher level words and combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -162,8 +115,8 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
>r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
r> [ with-pango ] curry with-cairo-from-surface ; inline
: layout-size ( quot -- width height )
[ layout pango-layout-get-pixel-size ] compose dummy-pango ; inline
: layout-size ( quot -- dim )
[ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
: layout-font ( str -- )
pango_font_description_from_string
@ -173,3 +126,6 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
: layout-text ( str -- )
layout swap -1 pango_layout_set_text ;
: families ( -- families )
pango_cairo_font_map_get_default list-families ;

30
extra/pango/cairo/gadgets/gadgets.factor Normal file
View File

@ -0,0 +1,30 @@
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: pango.cairo cairo cairo.ffi cairo.gadgets
alien.c-types kernel math ;
IN: pango.cairo.gadgets
: (pango-gadget) ( setup show -- gadget )
[ drop layout-size ]
[ compose [ with-pango ] curry <cairo-gadget> ] 2bi ;
: <pango-gadget> ( quot -- gadget )
[ cr layout pango_cairo_show_layout ] (pango-gadget) ;
USING: prettyprint sequences ui.gadgets.panes
threads io.backend io.encodings.utf8 io.files ;
: hello-pango ( -- )
50 [ 6 + ] map [
"Sans " swap unparse append
[
cr 0 1 0.2 0.6 cairo_set_source_rgba
layout-font "今日は、 Pango!" layout-text
] curry
<pango-gadget> gadget. yield
] each
[
"resource:extra/pango/cairo/gadgets/gadgets.factor"
normalize-path utf8 file-contents layout-text
] <pango-gadget> gadget. ;
MAIN: hello-pango

40
extra/pango/fonts/fonts.factor Normal file
View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license
USING: pango alien.syntax alien.c-types
kernel ;
IN: pango.fonts
LIBRARY: pango
FUNCTION: void
pango_font_map_list_families ( PangoFontMap* fontmap, PangoFontFamily*** families, int* n_families ) ;
FUNCTION: char*
pango_font_family_get_name ( PangoFontFamily* family ) ;
FUNCTION: int
pango_font_family_is_monospace ( PangoFontFamily* family ) ;
FUNCTION: void
pango_font_family_list_faces ( PangoFontFamily* family, PangoFontFace*** faces, int* n_faces ) ;
FUNCTION: char*
pango_font_face_get_face_name ( PangoFontFace* face ) ;
FUNCTION: void
pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ;
: list-families ( PangoFontMap* -- PangoFontFamily*-seq )
0 <int> 0 <int> [ pango_font_map_list_families ] 2keep
*int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
: list-faces ( PangoFontFamily* -- PangoFontFace*-seq )
0 <int> 0 <int> [ pango_font_family_list_faces ] 2keep
*int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
: list-sizes ( PangoFontFace* -- ints )
0 <int> 0 <int> [ pango_font_face_list_sizes ] 2keep
*int swap *void* [ swap c-int-array> ] [ g_free ] bi ;
: monospace? ( PangoFontFamily* -- ? )
pango_font_family_is_monospace 1 = ;

59
extra/pango/pango.factor Normal file
View File

@ -0,0 +1,59 @@
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license
USING: system
alien.c-types alien.syntax alien combinators ;
IN: pango
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Helpful functions from other parts of pango
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<< "pango" {
! { [ os winnt? ] [ "libpango-1.dll" ] }
! { [ os macosx? ] [ "libpango.dylib" ] }
{ [ os unix? ] [ "libpango-1.0.so" ] }
} cond "cdecl" add-library >>
LIBRARY: pango
: PANGO_SCALE 1024 ;
FUNCTION: void
pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
FUNCTION: char*
pango_layout_get_text ( PangoLayout* layout ) ;
FUNCTION: void
pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ;
FUNCTION: PangoFontDescription*
pango_font_description_from_string ( char* str ) ;
FUNCTION: char*
pango_font_description_to_string ( PangoFontDescription* desc ) ;
FUNCTION: char*
pango_font_description_to_filename ( PangoFontDescription* desc ) ;
FUNCTION: void
pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ;
FUNCTION: PangoFontDescription*
pango_layout_get_font_description ( PangoLayout* layout ) ;
FUNCTION: void
pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ;
FUNCTION: void
pango_font_description_free ( PangoFontDescription* desc ) ;
! glib functions
TYPEDEF: void* gpointer
FUNCTION: void
g_object_unref ( gpointer object ) ;
FUNCTION: void
g_free ( gpointer mem ) ;

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

1
extra/urls/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
extra/urls/summary.txt Normal file
View File

@ -0,0 +1 @@
Tools for working with URLs (uniform resource locators)

2
extra/urls/tags.txt Normal file
View File

@ -0,0 +1,2 @@
web
network

194
extra/urls/urls-tests.factor Normal file
View File

@ -0,0 +1,194 @@
IN: urls.tests
USING: urls tools.test tuple-syntax arrays kernel assocs ;
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ f ] [ "%XX%XX%XX" url-decode ] unit-test
[ f ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello+world" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test
[ "hello world" ] [ "hello world%" url-decode ] unit-test
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
: urls
{
{
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
"http://www.apple.com:1234/a/path?a=b#foo"
}
{
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/a/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
"http://www.apple.com/a/path?a=b#foo"
}
{
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/another/fine/path"
anchor: "foo"
}
"http://www.apple.com:1234/another/fine/path#foo"
}
{
TUPLE{ url
path: "/a/relative/path"
anchor: "foo"
}
"/a/relative/path#foo"
}
{
TUPLE{ url
path: "/a/relative/path"
}
"/a/relative/path"
}
{
TUPLE{ url
path: "a/relative/path"
}
"a/relative/path"
}
} ;
urls [
[ 1array ] [ [ string>url ] curry ] bi* unit-test
] assoc-each
urls [
swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
] assoc-each
[ "b" ] [ "a" "b" url-append-path ] unit-test
[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test
[ "a/b" ] [ "a/" "b" url-append-path ] unit-test
[ "/b" ] [ "a" "/b" url-append-path ] unit-test
[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test
[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/foo"
}
TUPLE{ url
path: "/a/path"
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/"
}
TUPLE{ url
path: "relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/"
}
TUPLE{ url
path: "relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/xxx/baz"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/xxx/bar"
}
TUPLE{ url
path: "baz"
}
derive-url
] unit-test

160
extra/urls/urls.factor Normal file
View File

@ -0,0 +1,160 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel unicode.categories combinators sequences splitting
fry namespaces assocs arrays strings mirrors
io.encodings.string io.encodings.utf8
math math.parser accessors namespaces.lib ;
IN: urls
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
{
{ [ dup letter? ] [ t ] }
{ [ dup LETTER? ] [ t ] }
{ [ dup digit? ] [ t ] }
{ [ dup "/_-.:" member? ] [ t ] }
[ f ]
} cond nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
2drop
] [
[ 1+ dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
2dup url-decode-hex [ 3 + ] dip ;
: url-decode-+-or-other ( index str ch -- index str )
dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
: url-decode-iter ( index str -- )
2dup length >= [
2drop
] [
2dup nth dup CHAR: % = [
drop url-decode-%
] [
url-decode-+-or-other
] if url-decode-iter
] if ;
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make utf8 decode ;
: add-query-param ( value key assoc -- )
[
at [
{
{ [ dup string? ] [ swap 2array ] }
{ [ dup array? ] [ swap suffix ] }
{ [ dup not ] [ drop ] }
} cond
] when*
] 2keep set-at ;
: query>assoc ( query -- assoc )
dup [
"&" split H{ } clone [
[
[ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
add-query-param
] curry each
] keep
] when ;
: assoc>query ( hash -- str )
[
{
{ [ dup number? ] [ number>string 1array ] }
{ [ dup string? ] [ 1array ] }
{ [ dup sequence? ] [ ] }
} cond
] assoc-map
[
[
[ url-encode ] dip
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
TUPLE: url protocol host port path query anchor ;
: query-param ( request key -- value )
swap query>> at ;
: set-query-param ( request value key -- request )
pick query>> set-at ;
: parse-host ( string -- host port )
":" split1 [ url-decode ] [
dup [
string>number
dup [ "Invalid port" throw ] unless
] when
] bi* ;
: parse-host-part ( protocol rest -- string' )
[ "protocol" set ] [
"//" ?head [ "Invalid URL" throw ] unless
"/" split1 [
parse-host [ "host" set ] [ "port" set ] bi*
] [ "/" prepend ] bi*
] bi* ;
: string>url ( string -- url )
[
":" split1 [ parse-host-part ] when*
"#" split1 [
"?" split1 [ query>assoc "query" set ] when*
url-decode "path" set
] [
url-decode "anchor" set
] bi*
] url make-object ;
: unparse-host-part ( protocol -- )
%
"://" %
"host" get url-encode %
"port" get [ ":" % # ] when*
"path" get "/" head? [ "Invalid URL" throw ] unless ;
: url>string ( url -- string )
[
<mirror> [
"protocol" get [ unparse-host-part ] when*
"path" get url-encode %
"query" get [ "?" % assoc>query % ] when*
"anchor" get [ "#" % url-encode % ] when*
] bind
] "" make ;
: url-append-path ( path1 path2 -- path )
{
{ [ dup "/" head? ] [ nip ] }
{ [ dup empty? ] [ drop ] }
{ [ over "/" tail? ] [ append ] }
{ [ "/" pick start not ] [ nip ] }
[ [ "/" last-split1 drop "/" ] dip 3append ]
} cond ;
: derive-url ( base url -- url' )
[ clone dup ] dip
2dup [ path>> ] bi@ url-append-path
[ [ <mirror> ] bi@ [ nip ] assoc-filter update ] dip
>>path ;
: relative-url ( url -- url' )
clone f >>protocol f >>host f >>port ;

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 ;

4
vm/callstack.c
View File

@ -109,9 +109,7 @@ CELL frame_executing(F_STACK_FRAME *frame)
{
F_COMPILED *compiled = frame_code(frame);
CELL code_start = (CELL)(compiled + 1);
CELL literal_start = code_start
+ compiled->code_length
+ compiled->reloc_length;
CELL literal_start = code_start + compiled->code_length;
return get(literal_start);
}

5
vm/code_gc.c
View File

@ -257,12 +257,13 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter)
}
/* Copy all literals referenced from a code block to newspace */
void collect_literals_step(F_COMPILED *compiled, CELL code_start,
CELL reloc_start, CELL literals_start)
void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
copy_handle(&compiled->relocation);
for(scan = literals_start; scan < literal_end; scan += CELLS)
copy_handle((CELL*)scan);
}

8
vm/code_gc.h
View File

@ -44,16 +44,14 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
/* compiled code */
F_HEAP code_heap;
typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
CELL reloc_start, CELL literals_start);
typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start);
INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
{
CELL code_start = (CELL)(compiled + 1);
CELL reloc_start = code_start + compiled->code_length;
CELL literals_start = reloc_start + compiled->reloc_length;
CELL literals_start = code_start + compiled->code_length;
iter(compiled,code_start,reloc_start,literals_start);
iter(compiled,code_start,literals_start);
}
INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)

31
vm/code_heap.c
View File

@ -139,13 +139,14 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
}
/* Perform all fixups on a code block */
void relocate_code_block(F_COMPILED *relocating, CELL code_start,
CELL reloc_start, CELL literals_start)
void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
if(reloc_start != literals_start)
if(compiled->relocation != F)
{
F_REL *rel = (F_REL *)reloc_start;
F_REL *rel_end = (F_REL *)literals_start;
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
@ -160,7 +161,7 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start,
}
}
flush_icache(code_start,reloc_start - code_start);
flush_icache(code_start,literals_start - code_start);
}
/* Fixup labels. This is done at compile time, not image load time */
@ -249,34 +250,32 @@ F_COMPILED *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
F_ARRAY *relocation,
CELL relocation,
F_ARRAY *literals)
{
CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format);
CELL rel_length = array_capacity(relocation) * sizeof(unsigned int);
CELL literals_length = array_capacity(literals) * CELLS;
REGISTER_ROOT(relocation);
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
REGISTER_UNTAGGED(relocation);
REGISTER_UNTAGGED(literals);
CELL here = allot_code_block(sizeof(F_COMPILED) + code_length
+ rel_length + literals_length);
CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
UNREGISTER_UNTAGGED(literals);
UNREGISTER_UNTAGGED(relocation);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
UNREGISTER_ROOT(relocation);
/* compiled header */
F_COMPILED *header = (void *)here;
header->type = type;
header->code_length = code_length;
header->reloc_length = rel_length;
header->literals_length = literals_length;
header->relocation = relocation;
here += sizeof(F_COMPILED);
@ -286,10 +285,6 @@ F_COMPILED *add_compiled_block(
deposit_integers(here,code,code_format);
here += code_length;
/* relation info */
deposit_integers(here,relocation,sizeof(unsigned int));
here += rel_length;
/* literals */
deposit_objects(here,literals);
here += literals_length;
@ -353,7 +348,7 @@ DEFINE_PRIMITIVE(modify_code_heap)
F_ARRAY *compiled_code = untag_array(data);
F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
F_ARRAY *relocation = untag_array(array_nth(compiled_code,1));
CELL relocation = array_nth(compiled_code,1);
F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
F_ARRAY *code = untag_array(array_nth(compiled_code,3));

5
vm/code_heap.h
View File

@ -53,8 +53,7 @@ typedef struct {
unsigned int offset;
} F_REL;
void relocate_code_block(F_COMPILED *relocating, CELL code_start,
CELL reloc_start, CELL literals_start);
void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start);
void default_word_code(F_WORD *word, bool relocate);
@ -64,7 +63,7 @@ F_COMPILED *add_compiled_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
F_ARRAY *rel,
CELL relocation,
F_ARRAY *literals);
CELL compiled_code_format(void);

26
vm/data_gc.c
View File

@ -930,22 +930,22 @@ DEFINE_PRIMITIVE(gc_stats)
for(i = 0; i < MAX_GEN_COUNT; i++)
{
F_GC_STATS *s = &gc_stats[i];
GROWABLE_ADD(stats,allot_cell(s->collections));
GROWABLE_ADD(stats,allot_cell(s->gc_time));
GROWABLE_ADD(stats,allot_cell(s->max_gc_time));
GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
GROWABLE_ADD(stats,allot_cell(s->object_count));
GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
GROWABLE_ARRAY_ADD(stats,allot_cell(s->gc_time));
GROWABLE_ARRAY_ADD(stats,allot_cell(s->max_gc_time));
GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
total_gc_time += s->gc_time;
}
GROWABLE_ADD(stats,allot_cell(total_gc_time));
GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
GROWABLE_ADD(stats,allot_cell(code_heap_scans));
GROWABLE_ARRAY_ADD(stats,allot_cell(total_gc_time));
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
GROWABLE_TRIM(stats);
GROWABLE_ARRAY_TRIM(stats);
dpush(stats);
}
@ -986,13 +986,13 @@ CELL find_all_words(void)
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
GROWABLE_ADD(words,obj);
GROWABLE_ARRAY_ADD(words,obj);
}
/* End heap scan */
gc_off = false;
GROWABLE_TRIM(words);
GROWABLE_ARRAY_TRIM(words);
return words;
}

7
vm/debug.c
View File

@ -296,8 +296,7 @@ void find_data_references(CELL look_for_)
CELL look_for;
void find_code_references_step(F_COMPILED *compiled, CELL code_start,
CELL reloc_start, CELL literals_start)
void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
@ -305,9 +304,7 @@ void find_code_references_step(F_COMPILED *compiled, CELL code_start,
for(scan = literals_start; scan < literal_end; scan += CELLS)
{
CELL code_start = (CELL)(compiled + 1);
CELL literal_start = code_start
+ compiled->code_length
+ compiled->reloc_length;
CELL literal_start = code_start + compiled->code_length;
CELL obj = get(literal_start);

10
vm/image.c
View File

@ -288,18 +288,18 @@ void relocate_data()
}
}
void fixup_code_block(F_COMPILED *relocating, CELL code_start,
CELL reloc_start, CELL literals_start)
void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
/* relocate literal table data */
CELL scan;
CELL literal_end = literals_start + relocating->literals_length;
CELL literal_end = literals_start + compiled->literals_length;
data_fixup(&compiled->relocation);
for(scan = literals_start; scan < literal_end; scan += CELLS)
data_fixup((CELL*)scan);
if(reloc_start != literals_start)
relocate_code_block(relocating,code_start,reloc_start,literals_start);
relocate_code_block(compiled,code_start,literals_start);
}
void relocate_code()

2
vm/layouts.h
View File

@ -113,8 +113,8 @@ typedef struct
{
CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
CELL code_length; /* # bytes */
CELL reloc_length; /* # bytes */
CELL literals_length; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
} F_COMPILED;
/* Assembly code makes assumptions about the layout of this struct */

8
vm/os-unix.c
View File

@ -73,14 +73,14 @@ DEFINE_PRIMITIVE(read_dir)
while((file = readdir(dir)) != NULL)
{
CELL pair = parse_dir_entry(file);
GROWABLE_ADD(result,pair);
GROWABLE_ARRAY_ADD(result,pair);
}
closedir(dir);
}
UNREGISTER_ROOT(result);
GROWABLE_TRIM(result);
GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
@ -104,12 +104,12 @@ DEFINE_PRIMITIVE(os_envs)
while(*env)
{
CELL string = tag_object(from_char_string(*env));
GROWABLE_ADD(result,string);
GROWABLE_ARRAY_ADD(result,string);
env++;
}
UNREGISTER_ROOT(result);
GROWABLE_TRIM(result);
GROWABLE_ARRAY_TRIM(result);
dpush(result);
}

4
vm/os-windows-nt.c
View File

@ -25,7 +25,7 @@ DEFINE_PRIMITIVE(os_envs)
break;
CELL string = tag_object(from_u16_string(finger));
GROWABLE_ADD(result,string);
GROWABLE_ARRAY_ADD(result,string);
finger = scan + 1;
}
@ -33,7 +33,7 @@ DEFINE_PRIMITIVE(os_envs)
FreeEnvironmentStrings(env);
UNREGISTER_ROOT(result);
GROWABLE_TRIM(result);
GROWABLE_ARRAY_TRIM(result);
dpush(result);
}

4
vm/os-windows.c
View File

@ -152,14 +152,14 @@ DEFINE_PRIMITIVE(read_dir)
CELL name = tag_object(from_u16_string(find_data.cFileName));
CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
CELL pair = allot_array_2(name,dirp);
GROWABLE_ADD(result,pair);
GROWABLE_ARRAY_ADD(result,pair);
}
while (FindNextFile(dir, &find_data));
FindClose(dir);
}
UNREGISTER_ROOT(result);
GROWABLE_TRIM(result);
GROWABLE_ARRAY_TRIM(result);
dpush(result);
}

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

35
vm/quotations.c
View File

@ -60,14 +60,9 @@ F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
#define EMIT(name,rel_argument) { \
bool rel_p; \
F_REL rel = rel_to_emit(name,code_format,code_count, \
rel_argument,&rel_p); \
if(rel_p) \
{ \
GROWABLE_ADD(relocation,allot_cell(rel.type)); \
GROWABLE_ADD(relocation,allot_cell(rel.offset)); \
} \
GROWABLE_APPEND(code,code_to_emit(name)); \
F_REL rel = rel_to_emit(name,code_format,code_count,rel_argument,&rel_p); \
if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
}
bool jit_stack_frame_p(F_ARRAY *array)
@ -110,13 +105,13 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY(code);
REGISTER_ROOT(code);
GROWABLE_ARRAY(relocation);
GROWABLE_BYTE_ARRAY(relocation);
REGISTER_ROOT(relocation);
GROWABLE_ARRAY(literals);
REGISTER_ROOT(literals);
GROWABLE_ADD(literals,stack_traces_p() ? quot : F);
GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F);
bool stack_frame = jit_stack_frame_p(untag_object(array));
@ -141,7 +136,7 @@ void jit_compile(CELL quot, bool relocate)
current stack frame. */
word = untag_object(obj);
GROWABLE_ADD(literals,array_nth(untag_object(array),i));
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1)
{
@ -157,7 +152,7 @@ void jit_compile(CELL quot, bool relocate)
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
GROWABLE_ADD(literals,wrapper->object);
GROWABLE_ARRAY_ADD(literals,wrapper->object);
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
break;
case FIXNUM_TYPE:
@ -176,8 +171,8 @@ void jit_compile(CELL quot, bool relocate)
if(stack_frame)
EMIT(JIT_EPILOG,0);
GROWABLE_ADD(literals,array_nth(untag_object(array),i));
GROWABLE_ADD(literals,array_nth(untag_object(array),i + 1));
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
EMIT(JIT_IF_JUMP,literals_count - 2);
i += 2;
@ -191,7 +186,7 @@ void jit_compile(CELL quot, bool relocate)
if(stack_frame)
EMIT(JIT_EPILOG,0);
GROWABLE_ADD(literals,array_nth(untag_object(array),i));
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(JIT_DISPATCH,literals_count - 1);
i++;
@ -200,7 +195,7 @@ void jit_compile(CELL quot, bool relocate)
break;
}
default:
GROWABLE_ADD(literals,obj);
GROWABLE_ARRAY_ADD(literals,obj);
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
break;
}
@ -214,15 +209,15 @@ void jit_compile(CELL quot, bool relocate)
EMIT(JIT_RETURN,0);
}
GROWABLE_TRIM(code);
GROWABLE_TRIM(relocation);
GROWABLE_TRIM(literals);
GROWABLE_ARRAY_TRIM(code);
GROWABLE_ARRAY_TRIM(literals);
GROWABLE_BYTE_ARRAY_TRIM(relocation);
F_COMPILED *compiled = add_compiled_block(
QUOTATION_TYPE,
untag_object(code),
NULL,
untag_object(relocation),
relocation,
untag_object(literals));
set_quot_xt(untag_object(quot),compiled);

35
vm/types.c
View File

@ -197,7 +197,7 @@ DEFINE_PRIMITIVE(resize_array)
dpush(tag_object(reallot_array(array,capacity,F)));
}
F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
{
REGISTER_ROOT(elt);
@ -209,12 +209,12 @@ F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
UNREGISTER_ROOT(elt);
set_array_nth(result,*result_count,elt);
*result_count = *result_count + 1;
(*result_count)++;
return result;
}
F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
{
REGISTER_UNTAGGED(elts);
@ -228,7 +228,7 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
write_barrier((CELL)result);
memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);
*result_count += elts_size;
@ -283,6 +283,33 @@ DEFINE_PRIMITIVE(resize_byte_array)
dpush(tag_object(reallot_byte_array(array,capacity)));
}
F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count)
{
if(*result_count == byte_array_capacity(result))
{
result = reallot_byte_array(result,*result_count * 2);
}
bput(BREF(result,*result_count),elt);
*result_count++;
return result;
}
F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
{
CELL new_size = *result_count + len;
if(new_size >= byte_array_capacity(result))
result = reallot_byte_array(result,new_size * 2);
memcpy((void *)BREF(result,*result_count),elts,len);
*result_count = new_size;
return result;
}
/* Bit arrays */
/* size is in bits */

33
vm/types.h
View File

@ -146,6 +146,7 @@ DECLARE_PRIMITIVE(float_array);
DECLARE_PRIMITIVE(clone);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
DECLARE_PRIMITIVE(resize_array);
DECLARE_PRIMITIVE(resize_byte_array);
DECLARE_PRIMITIVE(resize_bit_array);
@ -193,15 +194,33 @@ DECLARE_PRIMITIVE(wrapper);
CELL result##_count = 0; \
CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count);
F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count);
#define GROWABLE_ADD(result,elt) \
result = tag_object(growable_add(untag_object(result),elt,&result##_count))
#define GROWABLE_ARRAY_ADD(result,elt) \
result = tag_object(growable_array_add(untag_object(result),elt,&result##_count))
F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
#define GROWABLE_APPEND(result,elts) \
result = tag_object(growable_append(untag_object(result),elts,&result##_count))
#define GROWABLE_ARRAY_APPEND(result,elts) \
result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
#define GROWABLE_TRIM(result) \
#define GROWABLE_ARRAY_TRIM(result) \
result = tag_object(reallot_array(untag_object(result),result##_count,F))
/* Macros to simulate a byte vector in C */
#define GROWABLE_BYTE_ARRAY(result) \
CELL result##_count = 0; \
CELL result = tag_object(allot_byte_array(100))
F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count);
#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \
result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count))
F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count))
#define GROWABLE_BYTE_ARRAY_TRIM(result) \
result = tag_object(reallot_byte_array(untag_object(result),result##_count))