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-03-18 17:02:48 -04:00
parent b362175d43 4b2368e99f
commit d496065f89
124 changed files with 1829 additions and 728 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/alien/alien-docs.factor
View File

@ -65,8 +65,7 @@ HELP: dlclose ( dll -- )
HELP: load-library
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }

2
core/alien/alien.factor
View File

@ -57,7 +57,7 @@ TUPLE: library path abi dll ;
over dup [ dlopen ] when \ library construct-boa ;
: load-library ( name -- dll )
library library-dll ;
library dup [ library-dll ] when ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;

4
core/alien/c-types/c-types.factor
View File

@ -262,8 +262,8 @@ M: long-long-type box-return ( type -- )
r> add*
] when ;
: malloc-file-contents ( path -- alien )
binary file-contents malloc-byte-array ;
: malloc-file-contents ( path -- alien len )
binary file-contents dup malloc-byte-array swap length ;
[
[ alien-cell ]

1
core/bootstrap/stage1.factor
View File

@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ;
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
1 exit
] recover
] [
"Cannot find " write write "." print

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

@ -29,7 +29,9 @@ $nl
{ $subsection ignore-errors }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "errors-post-mortem" } ;
{ $subsection "errors-post-mortem" }
"When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ;
ARTICLE: "continuations.private" "Continuation implementation details"
"A continuation is simply a tuple holding the contents of the five stacks:"

2
core/debugger/debugger.factor
View File

@ -214,7 +214,7 @@ M: check-closed summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
drop "Invalid parameters for define-method" ;
drop "Invalid parameters for create-method" ;
M: check-tuple summary
drop "Invalid class for define-constructor" ;

6
core/definitions/definitions-tests.factor
View File

@ -1,10 +1,10 @@
IN: definitions.tests
USING: tools.test generic kernel definitions sequences
compiler.units ;
compiler.units words ;
TUPLE: combination-1 ;
M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
M: combination-1 perform-combination 2drop [ ] ;
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
@ -13,7 +13,7 @@ SYMBOL: generic-1
[
generic-1 T{ combination-1 } define-generic
[ ] object \ generic-1 define-method
object \ generic-1 create-method [ ] define
] with-compilation-unit
[ ] [

13
core/generic/generic-docs.factor
View File

@ -34,7 +34,7 @@ $nl
{ $subsection define-generic }
{ $subsection define-simple-generic }
"Methods can be added to existing generic words:"
{ $subsection define-method }
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
{ $subsection methods }
@ -123,7 +123,7 @@ HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } ;
{ method define-method POSTPONE: M: } related-words
{ method create-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
@ -140,16 +140,17 @@ HELP: order
HELP: check-method
{ $values { "class" class } { "generic" generic } }
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
HELP: define-method
{ $values { "quot" quotation } { "class" class } { "generic" generic } }
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
HELP: create-method
{ $values { "class" class } { "generic" generic } { "method" method-body } }
{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
{ $notes "To define a method, pass the output value to " { $link define } "." } ;
HELP: implementors
{ $values { "class" class } { "seq" "a sequence of generic words" } }

54
core/generic/generic.factor
View File

@ -17,10 +17,6 @@ M: object perform-combination
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry [ ] like ;
GENERIC: method-prologue ( class combination -- quot )
M: object method-prologue 2drop [ ] ;
GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
@ -50,55 +46,49 @@ TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
over class? over generic? and [
\ check-method construct-boa throw
] unless ;
] unless ; inline
: with-methods ( word quot -- )
: with-methods ( generic quot -- )
swap [ "methods" word-prop swap call ] keep make-generic ;
inline
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
: make-method-def ( quot class generic -- quot )
"combination" word-prop method-prologue swap append ;
PREDICATE: word method-body "method-def" word-prop >boolean ;
PREDICATE: word method-body
"method-generic" word-prop >boolean ;
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
: method-word-props ( quot class generic -- assoc )
: method-word-props ( class generic -- assoc )
[
"method-generic" set
"method-class" set
"method-def" set
] H{ } make-assoc ;
: <method> ( quot class generic -- method )
: <method> ( class generic -- method )
check-method
[ make-method-def ] 3keep
[ method-word-props ] 2keep
method-word-name f <word>
tuck set-word-props
dup rot define ;
[ set-word-props ] keep ;
: redefine-method ( quot class generic -- )
[ method swap "method-def" set-word-prop ] 3keep
[ make-method-def ] 2keep
method swap define ;
: reveal-method ( method class generic -- )
[ set-at ] with-methods ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
2dup method [
redefine-method
: create-method ( class generic -- method )
2dup method dup [
2nip
] [
[ <method> ] 2keep
[ set-at ] with-methods
drop [ <method> dup ] 2keep reveal-method
] if ;
: <default-method> ( generic combination -- method )
object bootstrap-word pick <method>
[ -rot make-default-method define ] keep ;
: define-default-method ( generic combination -- )
dupd make-default-method object bootstrap-word pick <method>
"default-method" set-word-prop ;
dupd <default-method> "default-method" set-word-prop ;
! Definition protocol
M: method-spec where
@ -108,11 +98,10 @@ M: method-spec set-where
first2 method set-where ;
M: method-spec definer
drop \ M: \ ; ;
first2 method definer ;
M: method-spec definition
first2 method dup
[ "method-def" word-prop ] when ;
first2 method definition ;
: forget-method ( class generic -- )
check-method
@ -125,9 +114,6 @@ M: method-spec forget*
M: method-body definer
drop \ M: \ ; ;
M: method-body definition
"method-def" word-prop ;
M: method-body forget*
dup "method-class" word-prop
swap "method-generic" word-prop

2
core/generic/math/math.factor
View File

@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
: applicable-method ( generic class -- quot )
over method
[ word-def ]
[ 1quotation ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot )

4
core/generic/standard/standard.factor
View File

@ -8,10 +8,6 @@ IN: generic.standard
TUPLE: standard-combination # ;
M: standard-combination method-prologue
standard-combination-# object
<array> swap add* [ declare ] curry ;
C: <standard-combination> standard-combination
SYMBOL: (dispatch#)

8
core/io/files/files-tests.factor
View File

@ -1,6 +1,10 @@
IN: io.files.tests
USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
[ t ] [ "blahblah" temp-file directory? ] unit-test
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
@ -123,3 +127,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ ] [ "append-test" ascii <file-appender> dispose ] unit-test

11
core/io/files/files.factor
View File

@ -86,15 +86,11 @@ SYMBOL: +unknown+
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
! : file-length ( path -- n ) stat drop 2nip ;
: file-modified ( path -- n ) stat >r 3drop r> ;
! : file-permissions ( path -- perm ) stat 2drop nip ;
: exists? ( path -- ? ) file-modified >boolean ;
: directory? ( path -- ? ) stat 3drop ;
: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
! Current working directory
HOOK: cd io-backend ( path -- )
@ -220,10 +216,7 @@ M: pathname <=> [ pathname-string ] compare ;
>r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str )
dupd [ file-info file-info-size read ] with-file-reader ;
! : file-contents ( path encoding -- str )
! dupd [ file-length read ] with-file-reader ;
<file-reader> contents ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline

8
core/io/io.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces sequences strings
continuations assocs io.styles sbufs ;
USING: hashtables generic kernel math namespaces sequences
continuations assocs io.styles ;
IN: io
GENERIC: stream-readln ( stream -- str )
@ -88,4 +88,6 @@ SYMBOL: stderr
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
: contents ( stream -- str )
2048 <sbuf> [ stream-copy ] keep >string ;
[
[ 65536 read dup ] [ ] [ drop ] unfold concat f like
] with-stream ;

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

@ -429,7 +429,14 @@ $nl
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
HELP: die
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } ;
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
{ $notes
"The term FEP originates from the Lisp machines of old. According to the Jargon File,"
$nl
{ $strong "fepped out" } " /fept owt/ " { $emphasis "adj." } " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'."
$nl
{ $url "http://www.jargon.net/jargonfile/f/feppedout.html" }
} ;
HELP: (clone) ( obj -- newobj )
{ $values { "obj" object } { "newobj" "a shallow copy" } }

36
core/optimizer/specializers/specializers.factor
View File

@ -24,20 +24,40 @@ IN: optimizer.specializers
\ dispatch ,
] [ ] make ;
: specializer-methods ( quot word -- default alist )
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
] { } map>assoc ;
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
swap "method-class" word-prop add* ;
: specialize-method ( quot method -- quot' )
method-declaration [ declare ] curry swap append ;
: specialize-quot ( quot specializer -- quot' )
dup { number } = [
drop tag-specializer
] [
specializer-cases alist>quot
] if ;
: standard-method? ( method -- ? )
dup method-body? [
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
: specialized-def ( word -- quot )
dup word-def swap "specializer" word-prop [
dup { number } = [
drop tag-specializer
] [
specializer-methods alist>quot
] if
] when* ;
dup word-def swap {
{ [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
{ [ t ] [ drop ] }
} cond ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;

20
core/parser/parser.factor
View File

@ -215,9 +215,6 @@ SYMBOL: in
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
: create-in ( string -- word )
in get create dup set-word dup save-location ;
TUPLE: unexpected want got ;
: unexpected ( want got -- * )
@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof
: parse-tokens ( end -- seq )
100 <vector> swap (parse-tokens) >array ;
: create-in ( string -- word )
in get create dup set-word dup save-location ;
: CREATE ( -- word ) scan create-in ;
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
: create-class-in ( word -- word )
in get create
dup save-class-location
@ -284,6 +288,12 @@ M: no-word summary
] ?if
] when ;
: create-method-in ( class generic -- method )
create-method f set-word dup save-location ;
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
TUPLE: staging-violation word ;
: staging-violation ( word -- * )
@ -355,7 +365,9 @@ TUPLE: bad-number ;
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
: (:) CREATE dup reset-generic parse-definition ;
: (:) CREATE-WORD parse-definition ;
: (M:) CREATE-METHOD parse-definition ;
GENERIC: expected>string ( obj -- str )

3
core/slots/slots.factor
View File

@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ;
C: <slot-spec> slot-spec
: define-typecheck ( class generic quot -- )
over define-simple-generic -rot define-method ;
over define-simple-generic
>r create-method r> define ;
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;

19
core/syntax/syntax.factor
View File

@ -97,7 +97,7 @@ IN: bootstrap.syntax
"parsing" [ word t "parsing" set-word-prop ] define-syntax
"SYMBOL:" [
CREATE dup reset-generic define-symbol
CREATE-WORD define-symbol
] define-syntax
"DEFER:" [
@ -111,31 +111,26 @@ IN: bootstrap.syntax
] define-syntax
"GENERIC:" [
CREATE dup reset-word
define-simple-generic
CREATE-GENERIC define-simple-generic
] define-syntax
"GENERIC#" [
CREATE dup reset-word
CREATE-GENERIC
scan-word <standard-combination> define-generic
] define-syntax
"MATH:" [
CREATE dup reset-word
CREATE-GENERIC
T{ math-combination } define-generic
] define-syntax
"HOOK:" [
CREATE dup reset-word scan-word
CREATE-GENERIC scan-word
<hook-combination> define-generic
] define-syntax
"M:" [
f set-word
location >r
scan-word bootstrap-word scan-word
[ parse-definition -rot define-method ] 2keep
2array r> remember-definition
(M:) define
] define-syntax
"UNION:" [
@ -163,7 +158,7 @@ IN: bootstrap.syntax
] define-syntax
"C:" [
CREATE dup reset-generic
CREATE-WORD
scan-word dup check-tuple
[ construct-boa ] curry define-inline
] define-syntax

2
core/threads/threads-tests.factor
View File

@ -14,3 +14,5 @@ yield
[ 3 ] [
[ 3 swap resume-with ] "Test suspend" suspend
] unit-test
[ f ] [ f get-global ] unit-test

2
core/threads/threads.factor
View File

@ -32,8 +32,6 @@ mailbox variables sleep-entry ;
: threads 41 getenv ;
threads global [ H{ } assoc-like ] change-at
: thread ( id -- thread ) threads at ;
: thread-registered? ( thread -- ? )

20
core/tuples/tuples-docs.factor
View File

@ -12,6 +12,22 @@ ARTICLE: "tuple-constructors" "Constructors and slots"
$nl
"A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: }
"Examples of constructors:"
{ $code
"TUPLE: color red green blue alpha ;"
""
"C: <rgba> rgba"
": <rgba> color construct-boa ; ! identical to above"
""
": <rgb>"
" { set-color-red set-color-green set-color-blue }"
" color construct ;"
": <rgb> f <rgba> ; ! identical to above"
""
": <color> construct-empty ;"
": <color> { } color construct ; ! identical to above"
": <color> f f f f <rgba> ; ! identical to above"
}
"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
ARTICLE: "tuple-delegation" "Delegation"
@ -48,8 +64,8 @@ ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
{ $subsection POSTPONE: TUPLE: }
"An example:"
{ $code "TUPLE: person name address phone ;" }
"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:"
{ $code "TUPLE: person name address phone ;" "C: <person> person" }
"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
{ $table
{ "Reader" "Writer" }
{ { $snippet "person-name" } { $snippet "set-person-name" } }

2
core/words/words.factor
View File

@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
: crossref? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ f ] }
{ [ dup "method-def" word-prop ] [ t ] }
{ [ dup "method-generic" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;

13
extra/assocs/lib/lib.factor
View File

@ -1,4 +1,5 @@
USING: assocs kernel vectors sequences namespaces ;
USING: arrays assocs kernel vectors sequences namespaces
random math.parser ;
IN: assocs.lib
: >set ( seq -- hash )
@ -35,3 +36,13 @@ IN: assocs.lib
[ with each ] curry assoc-each ; inline
: insert ( value variable -- ) namespace insert-at ;
: 2seq>assoc ( keys values exemplar -- assoc )
>r 2array flip r> assoc-like ;
: generate-key ( assoc -- str )
>r random-256 >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
: set-at-unique ( value assoc -- key )
dup generate-key [ swap set-at ] keep ;

1
extra/bootstrap/tools/tools.factor
View File

@ -13,5 +13,6 @@ USING: vocabs.loader sequences ;
"tools.threads"
"tools.vocabs"
"tools.vocabs.browser"
"tools.vocabs.monitor"
"editors"
} [ require ] each

10
extra/builder/benchmark/benchmark.factor
View File

@ -4,10 +4,12 @@ USING: kernel continuations arrays assocs sequences sorting math
IN: builder.benchmark
: passing-benchmarks ( table -- table )
[ second first2 number? swap number? and ] subset ;
! : passing-benchmarks ( table -- table )
! [ second first2 number? swap number? and ] subset ;
: simplify-table ( table -- table ) [ first2 second 2array ] map ;
: passing-benchmarks ( table -- table ) [ second number? ] subset ;
! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
: benchmark-difference ( old-table benchmark-result -- result-diff )
first2 >r
@ -17,7 +19,7 @@ IN: builder.benchmark
2array ;
: compare-tables ( old new -- table )
[ passing-benchmarks simplify-table ] 2apply
[ passing-benchmarks ] 2apply
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )

4
extra/builder/builder.factor
View File

@ -134,7 +134,9 @@ SYMBOL: build-status
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
"test-all-vocabs" eval-file test-failures.
"test-failures" cat
! "test-failures" eval-file test-failures.
"help-lint results:" print "help-lint" cat

16
extra/cairo-demo/cairo-demo.factor
View File

@ -6,7 +6,7 @@
! http://cairographics.org/samples/text/
USING: cairo math math.constants byte-arrays kernel ui ui.render
USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
ui.gadgets opengl.gl ;
IN: cairo-demo
@ -23,13 +23,15 @@ IN: cairo-demo
TUPLE: cairo-gadget image-array cairo-t ;
M: cairo-gadget draw-gadget* ( gadget -- )
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
>r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
cairo-gadget-image-array glDrawPixels ;
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
>r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
cairo-gadget-image-array glDrawPixels ;
: create-surface ( gadget -- cairo_surface_t )
make-image-array dup >r swap set-cairo-gadget-image-array r> convert-array-to-surface ;
make-image-array
[ swap set-cairo-gadget-image-array ] keep
convert-array-to-surface ;
: init-cairo ( gadget -- cairo_t )
create-surface cairo_create ;
@ -56,7 +58,7 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
cairo_fill ;
M: cairo-gadget graft* ( gadget -- )
dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
M: cairo-gadget ungraft* ( gadget -- )
cairo-gadget-cairo-t cairo_destroy ;

1
extra/cairo/authors.txt
View File

@ -1 +1,2 @@
Sampo Vuori
Doug Coleman

2
extra/cairo/cairo.factor → extra/cairo/ffi/ffi.factor
View File

@ -10,7 +10,7 @@
USING: alien alien.syntax combinators system ;
IN: cairo
IN: cairo.ffi
<< "cairo" {
{ [ win32? ] [ "cairo.dll" ] }

40
extra/cairo/lib/lib.factor Normal file
View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cairo.ffi continuations destructors
kernel libc locals math combinators.cleave shuffle new-slots
accessors ;
IN: cairo.lib
TUPLE: cairo-t alien ;
C: <cairo-t> cairo-t
M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
: cairo-t-destroy-always ( alien -- ) <cairo-t> add-always-destructor ;
: cairo-t-destroy-later ( alien -- ) <cairo-t> add-error-destructor ;
TUPLE: cairo-surface-t alien ;
C: <cairo-surface-t> cairo-surface-t
M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
: cairo-surface-t-destroy-always ( alien -- )
<cairo-surface-t> add-always-destructor ;
: cairo-surface-t-destroy-later ( alien -- )
<cairo-surface-t> add-error-destructor ;
: cairo-surface>array ( surface -- cairo-t byte-array )
[
dup
[ drop CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height ] tri
over 4 *
2dup * [
malloc dup free-always [
5 -nrot cairo_image_surface_create_for_data
dup cairo-surface-t-destroy-always
cairo_create dup cairo-t-destroy-later
[ swap 0 0 cairo_set_source_surface ] keep
dup cairo_paint
] keep
] keep memory>byte-array
] with-destructors ;

45
extra/cairo/png/png.factor Normal file
View File

@ -0,0 +1,45 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.cleave kernel new-slots
accessors math ui.gadgets ui.render opengl.gl byte-arrays
namespaces opengl cairo.ffi cairo.lib ;
IN: cairo.png
TUPLE: png surface width height cairo-t array ;
TUPLE: png-gadget png ;
: <png> ( path -- png )
cairo_image_surface_create_from_png
dup [ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height ] [ ] tri
cairo-surface>array png construct-boa ;
: write-png ( png path -- )
>r png-surface r>
cairo_surface_write_to_png
zero? [ "write png failed" throw ] unless ;
: <png-gadget> ( path -- gadget )
png-gadget construct-gadget swap
<png> >>png ;
M: png-gadget pref-dim* ( gadget -- )
png>>
[ width>> ] [ height>> ] bi 2array ;
M: png-gadget draw-gadget* ( gadget -- )
origin get [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
png>>
[ width>> ]
[ height>> GL_RGBA GL_UNSIGNED_BYTE ]
[ array>> ] tri
glDrawPixels
] with-translation ;
M: png-gadget graft* ( gadget -- )
drop ;
M: png-gadget ungraft* ( gadget -- )
png>> surface>> cairo_destroy ;

26
extra/combinators/cleave/cleave.factor
View File

@ -70,3 +70,29 @@ MACRO: spread ( seq -- )
swap
[ [ r> ] swap append ] map concat
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Cleave into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: words quotations fry arrays.lib ;
: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
: >quots ( seq -- seq ) [ >quot ] map ;
MACRO: <arr> ( seq -- )
[ >quots ] [ length ] bi
'[ , cleave , narray ] ;
MACRO: <2arr> ( seq -- )
[ >quots ] [ length ] bi
'[ , 2cleave , narray ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Spread into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: <arr*> ( seq -- )
[ >quots ] [ length ] bi
'[ , spread , narray ] ;

5
extra/db/db-tests.factor Executable file
View File

@ -0,0 +1,5 @@
IN: db.tests
USING: tools.test db kernel ;
{ 1 0 } [ [ drop ] query-each ] must-infer-as
{ 1 1 } [ [ ] query-map ] must-infer-as

24
extra/db/db.factor
View File

@ -33,6 +33,19 @@ HOOK: db-close db ( handle -- )
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
TUPLE: nonthrowable-statement ;
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
] [
nonthrowable-statement construct-delegate
] if ;
MIXIN: throwable-statement
INSTANCE: statement throwable-statement
INSTANCE: simple-statement throwable-statement
INSTANCE: prepared-statement throwable-statement
TUPLE: result-set sql in-params out-params handle n max ;
: <statement> ( sql in out -- statement )
{ (>>sql) (>>in-params) (>>out-params) } statement construct ;
@ -50,13 +63,22 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
: execute-statement ( statement -- )
GENERIC: execute-statement ( statement -- )
M: throwable-statement execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
query-results dispose
] if ;
M: nonthrowable-statement execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
[ query-results dispose ] [ 2drop ] recover
] if ;
: bind-statement ( obj statement -- )
swap >>bind-params
[ bind-statement* ] keep

4
extra/db/postgresql/lib/lib.factor
View File

@ -73,7 +73,7 @@ IN: db.postgresql.lib
sql-spec-type {
{ FACTOR-BLOB [
dup [
binary [ serialize ] with-byte-writer
object>bytes
malloc-byte-array/length ] [ 0 ] if ] }
{ BLOB [
dup [ malloc-byte-array/length ] [ 0 ] if ] }
@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
{ BLOB [ pq-get-blob ] }
{ FACTOR-BLOB [
pq-get-blob
dup [ binary [ deserialize ] with-byte-reader ] when ] }
dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
! PQgetlength PQgetisnull

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

@ -10,6 +10,7 @@ IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
INSTANCE: postgresql-statement throwable-statement
TUPLE: postgresql-result-set ;
: <postgresql-statement> ( statement in out -- postgresql-statement )
<statement>
@ -119,8 +120,8 @@ M: postgresql-db bind% ( spec -- )
: postgresql-make ( class quot -- )
>r sql-props r>
[ postgresql-counter off ] swap compose
{ "" { } { } } nmake <postgresql-statement> ;
[ postgresql-counter off call ] { "" { } { } } nmake
<postgresql-statement> ; inline
: create-table-sql ( class -- statement )
[
@ -194,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
");" 0%
] postgresql-make ;
M: postgresql-db <insert-assigned-statement> ( class -- statement )
M: postgresql-db <insert-nonnative-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%

2
extra/db/sqlite/ffi/ffi.factor
View File

@ -127,6 +127,6 @@ FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;

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

@ -94,7 +94,7 @@ IN: db.sqlite.lib
{ TIMESTAMP [ sqlite-bind-text-by-name ] }
{ BLOB [ sqlite-bind-blob-by-name ] }
{ FACTOR-BLOB [
binary [ serialize ] with-byte-writer
object>bytes
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
@ -102,17 +102,12 @@ IN: db.sqlite.lib
[ no-sql-type ]
} case ;
: sqlite-finalize ( handle -- )
sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- )
sqlite3_reset sqlite-check-result ;
: sqlite-#columns ( query -- int )
sqlite3_column_count ;
: sqlite-column ( handle index -- string )
sqlite3_column_text ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
: sqlite-column-blob ( handle index -- byte-array/f )
[ sqlite3_column_bytes ] 2keep
@ -126,6 +121,7 @@ IN: db.sqlite.lib
dup array? [ first ] when
{
{ +native-id+ [ sqlite3_column_int64 ] }
{ +random-id+ [ sqlite3_column_int64 ] }
{ INTEGER [ sqlite3_column_int ] }
{ BIG-INTEGER [ sqlite3_column_int64 ] }
{ DOUBLE [ sqlite3_column_double ] }
@ -138,7 +134,7 @@ IN: db.sqlite.lib
{ BLOB [ sqlite-column-blob ] }
{ FACTOR-BLOB [
sqlite-column-blob
dup [ binary [ deserialize ] with-byte-reader ] when
dup [ bytes>object ] when
] }
! { NULL [ 2drop f ] }
[ no-sql-type ]
@ -147,7 +143,7 @@ IN: db.sqlite.lib
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
: sqlite-step-has-more-rows? ( step-result -- bool )
: sqlite-step-has-more-rows? ( prepared -- bool )
dup SQLITE_ROW = [
drop t
] [

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

@ -6,6 +6,7 @@ prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
combinators.cleave io namespaces.lib ;
USE: tools.walker
IN: db.sqlite
TUPLE: sqlite-db path ;
@ -17,15 +18,12 @@ M: sqlite-db db-open ( db -- )
dup sqlite-db-path sqlite-open <db>
swap set-delegate ;
M: sqlite-db db-close ( handle -- )
sqlite-close ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- )
sqlite-db swap with-db ; inline
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
INSTANCE: sqlite-statement throwable-statement
TUPLE: sqlite-result-set has-more? ;
@ -38,12 +36,20 @@ M: sqlite-db <prepared-statement> ( str in out -- obj )
set-statement-in-params
set-statement-out-params
} statement construct
db get db-handle over statement-sql sqlite-prepare
over set-statement-handle
sqlite-statement construct-delegate ;
: sqlite-maybe-prepare ( statement -- statement )
dup statement-handle [
[
delegate
db get db-handle over statement-sql sqlite-prepare
swap set-statement-handle
] keep
] unless ;
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
statement-handle
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
@ -52,9 +58,11 @@ M: sqlite-result-set dispose ( result-set -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- )
sqlite-maybe-prepare
statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
dup statement-bound? [ dup reset-statement ] when
[ statement-bind-params ] [ statement-handle ] bi
sqlite-bind ;
@ -95,21 +103,17 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
M: sqlite-db begin-transaction ( -- )
"BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- )
"COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: sqlite-make ( class quot -- )
>r sql-props r>
{ "" { } { } } nmake <simple-statement> ;
{ "" { } { } } nmake <simple-statement> ; inline
M: sqlite-db create-sql-statement ( class -- statement )
[
@ -123,9 +127,7 @@ M: sqlite-db create-sql-statement ( class -- statement )
] sqlite-make ;
M: sqlite-db drop-sql-statement ( class -- statement )
[
"drop table " 0% 0% ";" 0% drop
] sqlite-make ;
[ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
@ -138,7 +140,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
");" 0%
] sqlite-make ;
M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
: where-primary-key% ( specs -- )
@ -188,6 +190,8 @@ M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +random-id+ "primary key" }
! { +nonnative-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
@ -195,10 +199,9 @@ M: sqlite-db modifier-table ( -- hashtable )
{ +not-null+ "not null" }
} ;
M: sqlite-db compound-modifier ( str obj -- newstr )
compound-type ;
M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
M: sqlite-db compound-type ( str seq -- newstr )
M: sqlite-db compound-type ( str seq -- str' )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
@ -207,6 +210,7 @@ M: sqlite-db compound-type ( str seq -- newstr )
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
{ +random-id+ "integer primary key" }
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
@ -219,5 +223,4 @@ M: sqlite-db type-table ( -- assoc )
{ FACTOR-BLOB "blob" }
} ;
M: sqlite-db create-type-table
type-table ;
M: sqlite-db create-type-table ( symbol -- str ) type-table ;

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

@ -9,7 +9,7 @@ IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob ;
: <person> ( name age real ts date time blob -- person )
: <person> ( name age real ts date time blob factor-blob -- person )
{
set-person-the-name
set-person-the-number
@ -190,11 +190,11 @@ TUPLE: annotation n paste-id summary author mode contents ;
: test-postgresql ( -- )
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
! [ native-person-schema test-tuples ] test-postgresql
! [ assigned-person-schema test-tuples ] test-postgresql
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
TUPLE: serialize-me id data ;
@ -239,3 +239,34 @@ TUPLE: exam id name score ;
;
! [ test-ranges ] test-sqlite
TUPLE: secret n message ;
C: <secret> secret
: test-random-id
secret "SECRET"
{
{ "n" "ID" +random-id+ }
{ "message" "MESSAGE" TEXT }
} define-persistent
[ ] [ secret ensure-table ] unit-test
[ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
[ ] [ T{ secret } select-tuples ] unit-test
;
! [ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
! [ assigned-person-schema test-repeated-insert ] test-sqlite
! [ native-person-schema test-tuples ] test-postgresql
! [ assigned-person-schema test-tuples ] test-postgresql
! [ assigned-person-schema test-repeated-insert ] test-postgresql
! \ insert-tuple must-infer
! \ update-tuple must-infer
! \ delete-tuple must-infer
! \ select-tuple must-infer
! \ define-persistent must-infer

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

@ -28,7 +28,7 @@ HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
HOOK: <insert-native-statement> db ( class -- obj )
HOOK: <insert-assigned-statement> db ( class -- obj )
HOOK: <insert-nonnative-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <update-tuples-statement> db ( class -- obj )
@ -36,7 +36,7 @@ HOOK: <update-tuples-statement> db ( class -- obj )
HOOK: <delete-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( class -- obj )
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: insert-tuple* db ( tuple statement -- )
@ -75,21 +75,25 @@ HOOK: insert-tuple* db ( tuple statement -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: ensure-table ( class -- )
[ dup drop-table ] ignore-errors create-table ;
[
drop-sql-statement make-nonthrowable
[ execute-statement ] with-disposals
] [ create-table ] bi ;
: insert-native ( tuple -- )
dup class
db get db-insert-statements [ <insert-native-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
: insert-assigned ( tuple -- )
: insert-nonnative ( tuple -- )
! TODO logic here for unique ids
dup class
db get db-insert-statements [ <insert-assigned-statement> ] cache
db get db-insert-statements [ <insert-nonnative-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
dup class db-columns find-primary-key assigned-id? [
insert-assigned
dup class db-columns find-primary-key nonnative-id? [
insert-nonnative
] [
insert-native
] if ;

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

@ -3,7 +3,8 @@
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors tuples combinators calendar.format symbols ;
mirrors tuples combinators calendar.format symbols
singleton ;
IN: db.types
HOOK: modifier-table db ( -- hash )
@ -14,22 +15,30 @@ HOOK: compound-type db ( str n -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
+serial+ +unique+ +default+ +null+ +not-null+
SINGLETON: +native-id+
SINGLETON: +assigned-id+
SINGLETON: +random-id+
UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
: (primary-key?) ( obj -- ? )
{ +native-id+ +assigned-id+ } member? ;
: primary-key? ( spec -- ? )
sql-spec-primary-key (primary-key?) ;
sql-spec-primary-key +primary-key+? ;
: native-id? ( spec -- ? )
sql-spec-primary-key +native-id+? ;
: nonnative-id? ( spec -- ? )
sql-spec-primary-key +nonnative-id+? ;
: normalize-spec ( spec -- )
dup sql-spec-type dup (primary-key?) [
dup sql-spec-type dup +primary-key+? [
swap set-sql-spec-primary-key
] [
drop dup sql-spec-modifiers [
(primary-key?)
+primary-key+?
] deep-find
[ swap set-sql-spec-primary-key ] [ drop ] if*
] if ;
@ -37,12 +46,6 @@ SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
: find-primary-key ( specs -- obj )
[ sql-spec-primary-key ] find nip ;
: native-id? ( spec -- ? )
sql-spec-primary-key +native-id+ = ;
: assigned-id? ( spec -- ? )
sql-spec-primary-key +assigned-id+ = ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
@ -69,7 +72,7 @@ TUPLE: no-sql-modifier ;
dup number? [ number>string ] when ;
: maybe-remove-id ( specs -- obj )
[ native-id? not ] subset ;
[ +native-id+? not ] subset ;
: remove-relations ( specs -- newcolumns )
[ relation? not ] subset ;

10
extra/delegate/delegate.factor
View File

@ -7,7 +7,7 @@ IN: delegate
swap { } like "protocol-words" set-word-prop ;
: PROTOCOL:
CREATE dup reset-generic dup define-symbol
CREATE-WORD dup define-symbol
parse-definition swap define-protocol ; parsing
PREDICATE: word protocol "protocol-words" word-prop ;
@ -27,11 +27,11 @@ M: tuple-class group-words
swap [ slot-spec-writer ] map append ;
: define-consult-method ( word class quot -- )
pick add spin define-method ;
pick add >r swap create-method r> define ;
: define-consult ( class group quot -- )
>r group-words r>
swapd [ define-consult-method ] 2curry each ;
>r group-words swap r>
[ define-consult-method ] 2curry each ;
: CONSULT:
scan-word scan-word parse-definition swapd define-consult ; parsing
@ -39,7 +39,7 @@ M: tuple-class group-words
: define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [
pick "methods" word-prop at dup
[ "method-def" word-prop spin define-method ]
[ >r swap create-method r> word-def define ]
[ 3drop ] if
] 2curry each ;

7
extra/destructors/destructors.factor
View File

@ -26,11 +26,14 @@ M: destructor dispose
: add-always-destructor ( obj -- )
<destructor> always-destructors get push ;
: dispose-each ( seq -- )
<reversed> [ dispose ] each ;
: do-always-destructors ( -- )
always-destructors get [ dispose ] each ;
always-destructors get dispose-each ;
: do-error-destructors ( -- )
error-destructors get [ dispose ] each ;
error-destructors get dispose-each ;
: with-destructors ( quot -- )
[

14
extra/hello-world/deploy.factor
View File

@ -1,14 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-io 2 }
{ deploy-math? f }
{ deploy-threads? f }
{ deploy-compiler? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-name "Hello world (console)" }
{ deploy-reflection 2 }
{ deploy-threads? f }
{ deploy-c-types? f }
{ deploy-compiler? f }
{ deploy-ui? f }
{ deploy-math? f }
{ deploy-reflection 1 }
{ deploy-word-defs? f }
{ deploy-io 2 }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
}

5
extra/help/help-tests.factor Normal file
View File

@ -0,0 +1,5 @@
IN: help.tests
USING: tools.test help kernel ;
[ 3 throw ] must-fail
[ ] [ :help ] unit-test

2
extra/help/help.factor
View File

@ -136,7 +136,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
":edit - jump to source location (parse errors only)" print
":get ( var -- value ) accesses variables at time of the error" print
":vars - list all variables at error time";
":vars - list all variables at error time" print ;
: :help ( -- )
error get delegates [ error-help ] map [ ] subset

1
extra/http/client/client-tests.factor
View File

@ -18,6 +18,7 @@ tuple-syntax namespaces ;
port: 80
version: "1.1"
cookies: V{ }
header: H{ }
}
] [
[

4
extra/http/http-tests.factor
View File

@ -5,8 +5,8 @@ IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
[ "" ] [ "%XX%XX%X" 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

1
extra/http/http.factor
View File

@ -180,6 +180,7 @@ cookies ;
request construct-empty
"1.1" >>version
http-port >>port
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies ;

15
extra/http/server/actions/actions-tests.factor
View File

@ -1,11 +1,16 @@
IN: http.server.actions.tests
USING: http.server.actions tools.test math math.parser
multiline namespaces http io.streams.string http.server
sequences accessors ;
USING: http.server.actions http.server.validators
tools.test math math.parser multiline namespaces http
io.streams.string http.server sequences accessors ;
[
"a" [ v-number ] { { "a" "123" } } validate-param
[ 123 ] [ "a" get ] unit-test
] with-scope
<action>
[ "a" get "b" get + ] >>display
{ { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
{ { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
"action-1" set
STRING: action-request-test-1
@ -23,7 +28,7 @@ blah
<action>
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
{ { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
{ { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
"action-2" set
STRING: action-request-test-2

33
extra/http/server/actions/actions.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots sequences kernel assocs combinators
http.server http.server.validators http hashtables namespaces
combinators.cleave fry continuations ;
combinators.cleave fry continuations locals ;
IN: http.server.actions
SYMBOL: +path+
@ -17,17 +17,13 @@ TUPLE: action init display submit get-params post-params ;
[ <400> ] >>display
[ <400> ] >>submit ;
: with-validator ( string quot -- result error? )
'[ , @ f ] [
dup validation-error? [ t ] [ rethrow ] if
] recover ; inline
: validate-param ( name validator assoc -- error? )
swap pick
>r >r at r> with-validator swap r> set ;
:: validate-param ( name validator assoc -- )
name assoc at validator with-validator name set ; inline
: action-params ( validators -- error? )
[ params get validate-param ] { } assoc>map [ ] contains? ;
validation-failed? off
params get '[ , validate-param ] assoc-each
validation-failed? get ;
: handle-get ( -- response )
action get get-params>> action-params [ <400> ] [
@ -42,10 +38,13 @@ TUPLE: action init display submit get-params post-params ;
action get display>> call exit-with ;
M: action call-responder ( path action -- response )
[ +path+ associate request-params union params set ]
[ action set ] bi*
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case ;
'[
, ,
[ +path+ associate request-params union params set ]
[ action set ] bi*
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case
] with-exit-continuation ;

19
extra/http/server/auth/auth.factor
View File

@ -1,9 +1,26 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: http.server.sessions accessors
http.server.auth.providers ;
http.server.auth.providers assocs namespaces kernel ;
IN: http.server.auth
SYMBOL: logged-in-user
SYMBOL: user-profile-changed?
GENERIC: init-user-profile ( responder -- )
M: object init-user-profile drop ;
: uid ( -- string ) logged-in-user sget username>> ;
: profile ( -- assoc ) logged-in-user sget profile>> ;
: uget ( key -- value )
profile at ;
: uset ( value key -- )
profile set-at user-profile-changed? on ;
: uchange ( quot key -- )
profile swap change-at
user-profile-changed? on ; inline

77
extra/http/server/auth/login/edit-profile.fhtml Executable file
View File

@ -0,0 +1,77 @@
<% USING: http.server.components http.server.auth.login
http.server namespaces kernel combinators ; %>
<html>
<body>
<h1>Edit profile</h1>
<form method="POST" action="edit-profile">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-view %></td>
</tr>
<tr>
<td>Real name:</td>
<td><% "realname" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<td>Current password:</td>
<td><% "password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>If you don't want to change your current password, leave this field blank.</td>
</tr>
<tr>
<td>New password:</td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>
<td>Verify:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>If you are changing your password, enter it twice to ensure it is correct.</td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
</table>
<p><input type="submit" value="Update" />
<% {
{ [ login-failed? get ] [ "invalid password" render-error ] }
{ [ password-mismatch? get ] [ "passwords do not match" render-error ] }
{ [ t ] [ ] }
} cond %>
</p>
</form>
</body>
</html>

132
extra/http/server/auth/login/login.factor
View File

@ -7,15 +7,30 @@ http.server.actions http.server.components http.server.sessions
http.server.templating.fhtml http.server.validators
http.server.auth http sequences io.files namespaces hashtables
fry io.sockets combinators.cleave arrays threads locals
qualified ;
qualified continuations destructors ;
IN: http.server.auth.login
QUALIFIED: smtp
TUPLE: login users ;
SYMBOL: post-login-url
SYMBOL: login-failed?
TUPLE: login users ;
: users login get users>> ;
! Destructor
TUPLE: user-saver user ;
C: <user-saver> user-saver
M: user-saver dispose
user-profile-changed? get [
user>> users update-user
] [ drop ] if ;
: save-user-after ( user -- )
<user-saver> add-always-destructor ;
! ! ! Login
: <login-form>
@ -49,7 +64,7 @@ SYMBOL: login-failed?
form validate-form
"password" value "username" value
login get users>> check-login [
users check-login [
successful-login
] [
login-failed? on
@ -67,7 +82,7 @@ SYMBOL: login-failed?
t >>required
add-field
"realname" <string> add-field
"password" <password>
"new-password" <password>
t >>required
add-field
"verify-password" <password>
@ -80,7 +95,7 @@ SYMBOL: password-mismatch?
SYMBOL: user-exists?
: same-password-twice ( -- )
"password" value "verify-password" value = [
"new-password" value "verify-password" value = [
password-mismatch? on
validation-failed
] unless ;
@ -102,19 +117,76 @@ SYMBOL: user-exists?
same-password-twice
<user> values get [
"username" get >>username
"realname" get >>realname
"password" get >>password
"email" get >>email
] bind
<user>
"username" value >>username
"realname" value >>realname
"new-password" value >>password
"email" value >>email
login get users>> new-user [
users new-user [
user-exists? on
validation-failed
] unless*
successful-login
login get responder>> init-user-profile
] >>submit
] ;
! ! ! Editing user profile
: <edit-profile-form> ( -- form )
"edit-profile" <form>
"resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template
"username" <username> add-field
"realname" <string> add-field
"password" <password> add-field
"new-password" <password> add-field
"verify-password" <password> add-field
"email" <email> add-field ;
SYMBOL: previous-page
:: <edit-profile-action> ( -- action )
[let | form [ <edit-profile-form> ] |
<action>
[
blank-values
logged-in-user sget
dup username>> "username" set-value
dup realname>> "realname" set-value
dup email>> "email" set-value
] >>init
[
"text/html" <content>
[ form edit-form ] >>body
] >>display
[
blank-values
uid "username" set-value
form validate-form
logged-in-user sget
"password" value empty? [
same-password-twice
"password" value uid users check-login
[ login-failed? on validation-failed ] unless
"new-password" value set-password
] unless
"realname" value >>realname
"email" value >>email
user-profile-changed? on
previous-page sget f <permanent-redirect>
] >>submit
] ;
@ -186,7 +258,7 @@ SYMBOL: lost-password-from
form validate-form
"email" value "username" value
login get users>> issue-ticket [
users issue-ticket [
send-password-email
] when*
@ -200,7 +272,7 @@ SYMBOL: lost-password-from
"username" <username> <hidden>
t >>required
add-field
"password" <password>
"new-password" <password>
t >>required
add-field
"verify-password" <password>
@ -239,9 +311,9 @@ SYMBOL: lost-password-from
"ticket" value
"username" value
login get users>> claim-ticket [
"password" value >>password
login get users>> update-user
users claim-ticket [
"new-password" value >>password
users update-user
"resource:extra/http/server/auth/login/recover-4.fhtml"
serve-template
@ -265,13 +337,19 @@ TUPLE: protected responder ;
C: <protected> protected
: show-login-page ( -- response )
request get request-url post-login-url sset
"login" f <permanent-redirect> ;
M: protected call-responder ( path responder -- response )
logged-in-user sget [ responder>> call-responder ] [
logged-in-user sget [
dup save-user-after
request get request-url previous-page sset
responder>> call-responder
] [
2drop
request get method>> { "GET" "HEAD" } member? [
request get request-url post-login-url sset
"login" f <permanent-redirect>
] [ <400> ] if
request get method>> { "GET" "HEAD" } member?
[ show-login-page ] [ <400> ] if
] if ;
M: login call-responder ( path responder -- response )
@ -283,10 +361,13 @@ M: login call-responder ( path responder -- response )
swap <protected> >>default
<login-action> "login" add-responder
<logout-action> "logout" add-responder
no >>users ;
no-users >>users ;
! ! ! Configuration
: allow-edit-profile ( login -- login )
<edit-profile-action> <protected> "edit-profile" add-responder ;
: allow-registration ( login -- login )
<register-action> "register" add-responder ;
@ -294,6 +375,9 @@ M: login call-responder ( path responder -- response )
<recover-action-1> "recover-password" add-responder
<recover-action-3> "new-password" add-responder ;
: allow-edit-profile? ( -- ? )
login get responders>> "edit-profile" swap key? ;
: allow-registration? ( -- ? )
login get responders>> "register" swap key? ;

2
extra/http/server/auth/login/recover-3.fhtml
View File

@ -17,7 +17,7 @@ namespaces kernel combinators ; %>
<tr>
<td>Password:</td>
<td><% "password" component render-edit %></td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>

2
extra/http/server/auth/login/register.fhtml
View File

@ -26,7 +26,7 @@ http.server namespaces kernel combinators ; %>
<tr>
<td>Password:</td>
<td><% "password" component render-edit %></td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>

8
extra/http/server/auth/providers/assoc/assoc-tests.factor
View File

@ -3,7 +3,7 @@ USING: http.server.auth.providers
http.server.auth.providers.assoc tools.test
namespaces accessors kernel ;
<in-memory> "provider" set
<users-in-memory> "provider" set
[ t ] [
<user>
@ -22,11 +22,11 @@ namespaces accessors kernel ;
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
[ t ] [ "user" get >boolean ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
[ ] [ "user" get "fdasf" set-password drop ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test

12
extra/http/server/auth/providers/assoc/assoc.factor
View File

@ -4,16 +4,16 @@ IN: http.server.auth.providers.assoc
USING: new-slots accessors assocs kernel
http.server.auth.providers ;
TUPLE: in-memory assoc ;
TUPLE: users-in-memory assoc ;
: <in-memory> ( -- provider )
H{ } clone in-memory construct-boa ;
: <users-in-memory> ( -- provider )
H{ } clone users-in-memory construct-boa ;
M: in-memory get-user ( username provider -- user/f )
M: users-in-memory get-user ( username provider -- user/f )
assoc>> at ;
M: in-memory update-user ( user provider -- ) 2drop ;
M: users-in-memory update-user ( user provider -- ) 2drop ;
M: in-memory new-user ( user provider -- user/f )
M: users-in-memory new-user ( user provider -- user/f )
>r dup username>> r> assoc>>
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;

25
extra/http/server/auth/providers/db/db-tests.factor
View File

@ -4,35 +4,36 @@ http.server.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files accessors kernel ;
from-db "provider" set
users-in-db "provider" set
"auth-test.db" temp-file sqlite-db [
[ user drop-table ] ignore-errors
[ user create-table ] ignore-errors
init-users-table
[ t ] [
<user>
"slava" >>username
"foobar" >>password
"slava@factorcode.org" >>email
"provider" get new-user
username>> "slava" =
"slava" >>username
"foobar" >>password
"slava@factorcode.org" >>email
"provider" get new-user
username>> "slava" =
] unit-test
[ f ] [
<user>
"slava" >>username
"slava" >>username
"provider" get new-user
] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
[ t ] [ "user" get >boolean ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
[ ] [ "user" get "fdasf" set-password drop ] unit-test
[ ] [ "user" get "provider" get update-user ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test

13
extra/http/server/auth/providers/db/db.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db db.tuples db.types new-slots accessors
http.server.auth.providers kernel continuations ;
http.server.auth.providers kernel continuations
singleton ;
IN: http.server.auth.providers.db
user "USERS"
@ -16,20 +17,18 @@ user "USERS"
: init-users-table user ensure-table ;
TUPLE: from-db ;
: from-db T{ from-db } ;
SINGLETON: users-in-db
: find-user ( username -- user )
<user>
swap >>username
select-tuple ;
M: from-db get-user
M: users-in-db get-user
drop
find-user ;
M: from-db new-user
M: users-in-db new-user
drop
[
dup username>> find-user [
@ -39,5 +38,5 @@ M: from-db new-user
] if
] with-transaction ;
M: from-db update-user
M: users-in-db update-user
drop update-tuple ;

12
extra/http/server/auth/providers/null/null.factor
View File

@ -3,14 +3,12 @@
USING: http.server.auth.providers kernel ;
IN: http.server.auth.providers.null
! Named "no" because we can say no >>users
TUPLE: no-users ;
TUPLE: no ;
: no-users T{ no-users } ;
: no T{ no } ;
M: no-users get-user 2drop f ;
M: no get-user 2drop f ;
M: no-users new-user 2drop f ;
M: no new-user 2drop f ;
M: no update-user 2drop ;
M: no-users update-user 2drop ;

11
extra/http/server/auth/providers/providers.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel new-slots accessors random math.parser locals
sequences math ;
sequences math crypto.sha2 ;
IN: http.server.auth.providers
TUPLE: user username realname password email ticket profile ;
@ -17,14 +17,7 @@ GENERIC: new-user ( user provider -- user/f )
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
:: set-password ( password username provider -- ? )
[let | user [ username provider get-user ] |
user [
user
password >>password
provider update-user t
] [ f ] if
] ;
: set-password ( user password -- user ) >>password ;
! Password recovery support

17
extra/http/server/callbacks/callbacks.factor
View File

@ -4,7 +4,7 @@
USING: html http http.server io kernel math namespaces
continuations calendar sequences assocs new-slots hashtables
accessors arrays alarms quotations combinators
combinators.cleave fry ;
combinators.cleave fry assocs.lib ;
IN: http.server.callbacks
SYMBOL: responder
@ -98,11 +98,18 @@ SYMBOL: current-show
cont-id query-param swap callbacks>> at ;
M: callback-responder call-responder ( path responder -- response )
[ callback-responder set ]
[ request get resuming-callback ] bi
'[
, ,
[ invoke-callback ]
[ callback-responder get responder>> call-responder ] ?if ;
[ callback-responder set ]
[ request get resuming-callback ] bi
[
invoke-callback
] [
callback-responder get responder>> call-responder
] ?if
] with-exit-continuation ;
: show-page ( quot -- )
>r redirect-to-here store-current-show r>

21
extra/http/server/components/components-tests.factor
View File

@ -86,3 +86,24 @@ TUPLE: test-tuple text number more-text ;
[ t ] [ "number" value validation-error? ] unit-test
] with-scope
[
[ ] [
"n" <number>
0 >>min-value
10 >>max-value
"n" set
] unit-test
[ "123" ] [
"123" "n" get validate value>>
] unit-test
[ ] [ "n" get t >>integer drop ] unit-test
[ 3 ] [
"3" "n" get validate
] unit-test
] with-scope
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test

21
extra/http/server/components/components.factor
View File

@ -7,8 +7,6 @@ http.server.actions splitting mirrors hashtables
combinators.cleave fry continuations math ;
IN: http.server.components
SYMBOL: validation-failed?
SYMBOL: components
TUPLE: component id required default ;
@ -30,16 +28,13 @@ SYMBOL: values
: validate ( value component -- result )
'[
, ,
,
over empty? [
[ default>> [ v-default ] when* ]
[ required>> [ v-required ] when ]
bi
] [ validate* ] if
] [
dup validation-error?
[ validation-failed? on ] [ rethrow ] if
] recover ;
] with-validator ;
: render-view ( component -- )
[ id>> value ] [ render-view* ] bi ;
@ -192,15 +187,16 @@ M: password render-error*
render-edit* render-error ;
! Number fields
TUPLE: number min-value max-value ;
TUPLE: number min-value max-value integer ;
: <number> ( id -- component ) number <component> ;
M: number validate*
[ v-number ] [
[ integer>> [ v-integer ] when ]
[ min-value>> [ v-min-value ] when* ]
[ max-value>> [ v-max-value ] when* ]
bi
tri
] bi* ;
M: number render-view*
@ -215,7 +211,12 @@ M: number render-error*
! Text areas
TUPLE: text ;
: <text> ( id -- component ) <string> text construct-delegate ;
: <text> ( id -- component ) text <component> ;
M: text validate* drop ;
M: text render-view*
drop write ;
: render-textarea
<textarea

71
extra/http/server/server.factor
View File

@ -108,10 +108,6 @@ TUPLE: dispatcher default responders ;
: <dispatcher> ( -- dispatcher )
404-responder get H{ } clone dispatcher construct-boa ;
: set-main ( dispatcher name -- dispatcher )
'[ , f <permanent-redirect> ] <trivial-responder>
>>default ;
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
@ -124,28 +120,36 @@ TUPLE: dispatcher default responders ;
M: dispatcher call-responder ( path dispatcher -- response )
over [
2dup find-responder call-responder [
2nip
] [
default>> [
call-responder
] [
drop f
] if*
] if*
find-responder call-responder
] [
2drop redirect-with-/
] if ;
: <webapp> ( class -- dispatcher )
<dispatcher> swap construct-delegate ; inline
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
404-responder get H{ } clone vhost-dispatcher construct-boa ;
: find-vhost ( dispatcher -- responder )
request get host>> over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder ( path dispatcher -- response )
find-vhost call-responder ;
: set-main ( dispatcher name -- dispatcher )
'[ , f <permanent-redirect> ] <trivial-responder>
>>default ;
: add-responder ( dispatcher responder path -- dispatcher )
pick responders>> set-at ;
: add-main-responder ( dispatcher responder path -- dispatcher )
[ add-responder ] keep set-main ;
: <webapp> ( class -- dispatcher )
<dispatcher> swap construct-delegate ; inline
SYMBOL: main-responder
main-responder global
@ -181,21 +185,20 @@ SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
: do-request ( request -- response )
'[
exit-continuation set ,
[
[ log-request ]
[ request set ]
[ path>> main-responder get call-responder ] tri
[ <404> ] unless*
] [
[ \ do-request log-error ]
[ <500> ]
bi
] recover
] callcc1
exit-continuation off ;
[
[ log-request ]
[ request set ]
[ path>> main-responder get call-responder ] tri
[ <404> ] unless*
] [
[ \ do-request log-error ]
[ <500> ]
bi
] recover ;
: default-timeout 1 minutes stdio get set-timeout ;
@ -219,11 +222,3 @@ SYMBOL: exit-continuation
: httpd-main ( -- ) 8888 httpd ;
MAIN: httpd-main
! Utility
: generate-key ( assoc -- str )
>r random-256 >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
: set-at-unique ( value assoc -- key )
dup generate-key [ swap set-at ] keep ;

120
extra/http/server/sessions/sessions-tests.factor
View File

@ -1,6 +1,8 @@
IN: http.server.sessions.tests
USING: tools.test http.server.sessions math namespaces
kernel accessors ;
USING: tools.test http http.server.sessions
http.server.sessions.storage http.server.sessions.storage.assoc
http.server.actions http.server math namespaces kernel accessors
prettyprint io.streams.string splitting destructors sequences ;
[ H{ } ] [ H{ } add-session-id ] unit-test
@ -12,7 +14,16 @@ C: <foo> foo
M: foo init-session* drop 0 "x" sset ;
f <session> "123" >>id [
M: foo call-responder
2drop
"x" [ 1+ ] schange
"text/html" <content> [ "x" sget pprint ] >>body ;
[
"123" session-id set
H{ } clone session set
session-changed? off
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
[ ] [ 3 "x" sset ] unit-test
@ -22,22 +33,113 @@ f <session> "123" >>id [
[ ] [ "x" [ 1- ] schange ] unit-test
[ 4 ] [ "x" sget sq ] unit-test
] with-session
[ t ] [ session-changed? get ] unit-test
] with-scope
[ t ] [ f <url-sessions> url-sessions? ] unit-test
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
[ ] [
<foo> <url-sessions>
<sessions-in-memory> >>sessions
"manager" set
] unit-test
[ { 5 0 } ] [
[
"manager" get new-session
dup "manager" get get-session [ 5 "a" sset ] with-session
dup "manager" get get-session [ "a" sget , ] with-session
dup "manager" get get-session [ "x" sget , ] with-session
"manager" get get-session delete-session
"manager" get begin-session drop
dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session
dup "manager" get sessions>> get-session [ "a" sget , ] with-session
dup "manager" get sessions>> get-session [ "x" sget , ] with-session
"manager" get sessions>> get-session
"manager" get sessions>> delete-session
] { } make
] unit-test
[ ] [
<request>
"GET" >>method
request set
"/etc" "manager" get call-responder
response set
] unit-test
[ 307 ] [ response get code>> ] unit-test
[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
: url-responder-mock-test
[
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
[ "1" ] [ url-responder-mock-test ] unit-test
[ "2" ] [ url-responder-mock-test ] unit-test
[ "3" ] [ url-responder-mock-test ] unit-test
[ "4" ] [ url-responder-mock-test ] unit-test
[ ] [
<foo> <cookie-sessions>
<sessions-in-memory> >>sessions
"manager" set
] unit-test
[
<request>
"GET" >>method
"/" >>path
request set
"/etc" "manager" get call-responder response set
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
response get
] with-destructors
response set
[ ] [ response get cookies>> "cookies" set ] unit-test
: cookie-responder-mock-test
[
<request>
"GET" >>method
"cookies" get >>cookies
"/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
[ "2" ] [ cookie-responder-mock-test ] unit-test
[ "3" ] [ cookie-responder-mock-test ] unit-test
[ "4" ] [ cookie-responder-mock-test ] unit-test
: <exiting-action>
<action>
[
"text/plain" <content> exit-with
] >>display ;
[
[ ] [
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
[
"/" <exiting-action> <cookie-sessions>
call-responder
] with-destructors response set
] unit-test
[ "text/plain" ] [ response get "content-type" header ] unit-test
[ f ] [ response get cookies>> empty? ] unit-test
] with-scope

128
extra/http/server/sessions/sessions.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random
boxes alarms new-slots accessors http http.server
new-slots accessors http http.server
http.server.sessions.storage http.server.sessions.storage.assoc
quotations hashtables sequences fry combinators.cleave
html.elements ;
html.elements symbols continuations destructors ;
IN: http.server.sessions
! ! ! ! ! !
@ -12,61 +13,56 @@ IN: http.server.sessions
GENERIC: init-session* ( responder -- )
M: dispatcher init-session* drop ;
M: object init-session* drop ;
TUPLE: session-manager responder sessions ;
: <session-manager> ( responder class -- responder' )
>r H{ } clone session-manager construct-boa r>
construct-delegate ; inline
>r <sessions-in-memory> session-manager construct-boa
r> construct-delegate ; inline
TUPLE: session manager id namespace alarm ;
SYMBOLS: session session-id session-changed? ;
: <session> ( manager -- session )
f H{ } clone <box> \ session construct-boa ;
: sget ( key -- value )
session get at ;
: timeout ( -- dt ) 20 minutes ;
: sset ( value key -- )
session get set-at
session-changed? on ;
: cancel-timeout ( session -- )
alarm>> [ cancel-alarm ] if-box? ;
: schange ( key quot -- )
session get swap change-at
session-changed? on ; inline
: delete-session ( session -- )
[ cancel-timeout ]
[ dup manager>> sessions>> delete-at ]
bi ;
: sessions session-manager get sessions>> ;
: touch-session ( session -- session )
[ cancel-timeout ]
[ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
[ ]
tri ;
: managed-responder session-manager get responder>> ;
: session ( -- assoc ) \ session get namespace>> ;
: init-session ( managed -- session )
H{ } clone [ session [ init-session* ] with-variable ] keep ;
: sget ( key -- value ) session at ;
: begin-session ( responder -- id session )
[ responder>> init-session ] [ sessions>> ] bi
[ new-session ] [ drop ] 2bi ;
: sset ( value key -- ) session set-at ;
! Destructor
TUPLE: session-saver id session ;
: schange ( key quot -- ) session swap change-at ; inline
C: <session-saver> session-saver
: init-session ( session -- session )
dup dup \ session [
manager>> responder>> init-session*
] with-variable ;
M: session-saver dispose
session-changed? get [
[ session>> ] [ id>> ] bi
sessions update-session
] [ drop ] if ;
: new-session ( responder -- id )
[ <session> init-session touch-session ]
[ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
bi id>> ;
: save-session-after ( id session -- )
<session-saver> add-always-destructor ;
: get-session ( id responder -- session/f )
sessions>> at* [ touch-session ] when ;
: call-responder/session ( path responder session -- response )
\ session set responder>> call-responder ;
: sessions ( -- manager/f )
\ session get dup [ manager>> ] when ;
: call-responder/session ( path responder id session -- response )
[ save-session-after ]
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ;
TUPLE: null-sessions ;
@ -74,56 +70,64 @@ TUPLE: null-sessions ;
null-sessions <session-manager> ;
M: null-sessions call-responder ( path responder -- response )
dup <session> call-responder/session ;
H{ } clone f call-responder/session ;
TUPLE: url-sessions ;
: <url-sessions> ( responder -- responder' )
url-sessions <session-manager> ;
: sess-id "factorsessid" ;
: session-id-key "factorsessid" ;
: current-session ( responder -- session )
>r request-params sess-id swap at r> get-session ;
: current-url-session ( responder -- id/f session/f )
[ request-params session-id-key swap at ] [ sessions>> ] bi*
[ drop ] [ get-session ] 2bi ;
: add-session-id ( query -- query' )
\ session get [ id>> sess-id associate union ] when* ;
session-id get [ session-id-key associate union ] when* ;
: session-form-field ( -- )
<input
"hidden" =type
sess-id =id
sess-id =name
\ session get id>> =value
"hidden" =type
session-id-key =id
session-id-key =name
session-id get =value
input/> ;
: new-url-session ( responder -- response )
[ f ] [ begin-session drop session-id-key associate ] bi*
<temporary-redirect> ;
M: url-sessions call-responder ( path responder -- response )
[ add-session-id ] link-hook set
[ session-form-field ] form-hook set
dup current-session [
dup current-url-session dup [
call-responder/session
] [
nip
f swap new-session sess-id associate <temporary-redirect>
] if* ;
2drop nip new-url-session
] if ;
TUPLE: cookie-sessions ;
: <cookie-sessions> ( responder -- responder' )
cookie-sessions <session-manager> ;
: get-session-cookie ( responder -- cookie )
request get sess-id get-cookie
[ value>> swap get-session ] [ drop f ] if* ;
: current-cookie-session ( responder -- id namespace/f )
request get session-id-key get-cookie dup
[ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
: <session-cookie> ( id -- cookie )
sess-id <cookie> ;
session-id-key <cookie> ;
: call-responder/new-session ( path responder -- response )
dup begin-session
[ call-responder/session ]
[ drop <session-cookie> ] 2bi
put-cookie ;
M: cookie-sessions call-responder ( path responder -- response )
dup get-session-cookie [
dup current-cookie-session dup [
call-responder/session
] [
dup new-session
[ over get-session call-responder/session ] keep
<session-cookie> put-cookie
] if* ;
2drop call-responder/new-session
] if ;

38
extra/http/server/sessions/storage/assoc/assoc.factor Executable file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs assocs.lib new-slots accessors
http.server.sessions.storage combinators.cleave alarms kernel
fry http.server ;
IN: http.server.sessions.storage.assoc
TUPLE: sessions-in-memory sessions alarms ;
: <sessions-in-memory> ( -- storage )
H{ } clone H{ } clone sessions-in-memory construct-boa ;
: cancel-session-timeout ( id storage -- )
alarms>> at [ cancel-alarm ] when* ;
: touch-session ( id storage -- )
[ cancel-session-timeout ]
[ '[ , , delete-session ] timeout later ]
[ alarms>> set-at ]
2tri ;
M: sessions-in-memory get-session ( id storage -- namespace )
[ sessions>> at ] [ touch-session ] 2bi ;
M: sessions-in-memory update-session ( namespace id storage -- )
[ sessions>> set-at ]
[ touch-session ]
2bi ;
M: sessions-in-memory delete-session ( id storage -- )
[ sessions>> delete-at ]
[ cancel-session-timeout ]
2bi ;
M: sessions-in-memory new-session ( namespace storage -- id )
[ sessions>> set-at-unique ]
[ [ touch-session ] [ drop ] 2bi ]
bi ;

24
extra/http/server/sessions/storage/db/db-tests.factor Executable file
View File

@ -0,0 +1,24 @@
IN: http.server.sessions.storage.db
USING: http.server.sessions.storage
http.server.sessions.storage.db namespaces io.files
db.sqlite db accessors math tools.test kernel assocs
sequences ;
sessions-in-db "storage" set
"auth-test.db" temp-file sqlite-db [
[ ] [ init-sessions-table ] unit-test
[ f ] [ H{ } "storage" get new-session empty? ] unit-test
H{ } "storage" get new-session "id" set
"id" get "storage" get get-session "session" set
"a" "b" "session" get set-at
"session" get "id" get "storage" get update-session
[ H{ { "b" "a" } } ] [
"id" get "storage" get get-session
] unit-test
] with-db

46
extra/http/server/sessions/storage/db/db.factor Executable file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs new-slots accessors http.server.sessions.storage
alarms kernel http.server db.tuples db.types singleton
combinators.cleave math.parser ;
IN: http.server.sessions.storage.db
SINGLETON: sessions-in-db
TUPLE: session id namespace ;
session "SESSIONS"
{
{ "id" "ID" INTEGER +native-id+ }
{ "namespace" "NAMESPACE" FACTOR-BLOB }
} define-persistent
: init-sessions-table session ensure-table ;
: <session> ( id -- session )
session construct-empty
swap dup [ string>number ] when >>id ;
M: sessions-in-db get-session ( id storage -- namespace/f )
drop
dup [
<session>
select-tuple dup [ namespace>> ] when
] when ;
M: sessions-in-db update-session ( namespace id storage -- )
drop
<session>
swap >>namespace
update-tuple ;
M: sessions-in-db delete-session ( id storage -- )
drop
<session>
delete-tuple ;
M: sessions-in-db new-session ( namespace storage -- id )
drop
f <session>
swap >>namespace
[ insert-tuple ] [ id>> number>string ] bi ;

14
extra/http/server/sessions/storage/storage.factor Executable file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar ;
IN: http.server.sessions.storage
: timeout 20 minutes ;
GENERIC: get-session ( id storage -- namespace )
GENERIC: update-session ( namespace id storage -- )
GENERIC: delete-session ( id storage -- )
GENERIC: new-session ( namespace storage -- id )

9
extra/http/server/validators/validators-tests.factor
View File

@ -2,7 +2,8 @@ IN: http.server.validators.tests
USING: kernel sequences tools.test http.server.validators
accessors ;
[ "foo" v-number ] [ validation-error? ] must-fail-with
[ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test
[ "slava@factorcode.org" ] [
"slava@factorcode.org" v-email
@ -13,10 +14,10 @@ accessors ;
] unit-test
[ "slava@factorcode.o" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with
[ "invalid e-mail" = ] must-fail-with
[ "sla@@factorcode.o" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with
[ "invalid e-mail" = ] must-fail-with
[ "slava@factorcodeorg" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with
[ "invalid e-mail" = ] must-fail-with

36
extra/http/server/validators/validators.factor
View File

@ -5,21 +5,26 @@ math.parser assocs new-slots regexp fry unicode.categories
combinators.cleave sequences ;
IN: http.server.validators
SYMBOL: validation-failed?
TUPLE: validation-error value reason ;
: validation-error ( value reason -- * )
\ validation-error construct-boa throw ;
C: <validation-error> validation-error
: with-validator ( value quot -- result )
[ validation-failed? on <validation-error> ] recover ;
inline
: v-default ( str def -- str )
over empty? spin ? ;
: v-required ( str -- str )
dup empty? [ "required" validation-error ] when ;
dup empty? [ "required" throw ] when ;
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
validation-error
throw
] [
drop
] if ;
@ -27,35 +32,34 @@ TUPLE: validation-error value reason ;
: v-max-length ( str n -- str )
over length over > [
[ "must be no more than " % # " characters" % ] "" make
validation-error
throw
] [
drop
] if ;
: v-number ( str -- n )
dup string>number [ ] [
"must be a number" validation-error
] ?if ;
dup string>number [ ] [ "must be a number" throw ] ?if ;
: v-integer ( n -- n )
dup integer? [ "must be an integer" throw ] unless ;
: v-min-value ( x n -- x )
2dup < [
[ "must be at least " % # ] "" make
validation-error
[ "must be at least " % # ] "" make throw
] [
drop
] if ;
: v-max-value ( x n -- x )
2dup > [
[ "must be no more than " % # ] "" make
validation-error
[ "must be no more than " % # ] "" make throw
] [
drop
] if ;
: v-regexp ( str what regexp -- str )
>r over r> matches?
[ drop ] [ "invalid " swap append validation-error ] if ;
[ drop ] [ "invalid " swap append throw ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
@ -64,12 +68,12 @@ TUPLE: validation-error value reason ;
v-regexp ;
: v-captcha ( str -- str )
dup empty? [ "must remain blank" validation-error ] unless ;
dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
dup "\r\n" seq-intersect empty?
[ "must be a single line" validation-error ] unless ;
[ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
dup [ alpha? ] all?
[ "must be a single word" validation-error ] unless ;
[ "must be a single word" throw ] unless ;

4
extra/io/unix/launcher/launcher-tests.factor Normal file → Executable file
View File

@ -34,7 +34,7 @@ accessors kernel sequences ;
ascii <process-stream> contents
] unit-test
[ "" ] [
[ f ] [
<process>
"cat"
"launcher-test-1" temp-file
@ -55,7 +55,7 @@ accessors kernel sequences ;
try-process
] unit-test
[ "" ] [
[ f ] [
"cat"
"launcher-test-1" temp-file
2array

2
extra/io/unix/unix.factor
View File

@ -3,5 +3,3 @@ io.unix.launcher io.unix.mmap io.backend
combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require
"tools.vocabs.monitor" require

2
extra/io/windows/files/files.factor
View File

@ -7,7 +7,7 @@ sequences namespaces words symbols ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
+directory+ +archive+ +device+ +normal+ +temporary+
+archive+ +device+ +normal+ +temporary+
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +encrypted+ ;

2
extra/io/windows/nt/nt.factor
View File

@ -13,5 +13,3 @@ USE: io.windows.files
USE: io.backend
T{ windows-nt-io } set-io-backend
"tools.vocabs.monitor" require

7
extra/io/windows/windows.factor
View File

@ -76,11 +76,8 @@ M: win32-file close-handle ( handle -- )
] when drop ;
: open-append ( path -- handle length )
dup file-info file-info-size dup [
>r (open-append) r> 2dup set-file-pointer
] [
drop open-write
] if ;
[ dup file-info file-info-size ] [ drop 0 ] recover
>r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;

4
extra/ldap/libldap/libldap.factor
View File

@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: ldap.libldap
<< "libldap" {
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
{ [ unix? ] [ "libldap.so" "cdecl" ] }
} cond add-library >>
: LDAP_VERSION1 1 ; inline

19
extra/locals/locals-tests.factor
View File

@ -1,5 +1,6 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint ;
namespaces arrays strings prettyprint io.streams.string parser
;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@ -178,3 +179,19 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
[ "[| a! | ]" ] [
[| a! | ] unparse
] unit-test
DEFER: xyzzy
[ ] [
"IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
<string-reader> "lambda-generic-test" parse-stream drop
] unit-test
[ 10 ] [ 10 xyzzy ] unit-test
[ ] [
"IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
<string-reader> "lambda-generic-test" parse-stream drop
] unit-test
[ 5 ] [ 10 xyzzy ] unit-test

20
extra/locals/locals.factor
View File

@ -249,13 +249,14 @@ M: wlet local-rewrite*
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals ;
: ((::)) ( word -- word quot )
: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
: (::) ( -- word quot )
CREATE dup reset-generic ((::)) ;
: (::) CREATE-WORD parse-locals-definition ;
: (M::) CREATE-METHOD parse-locals-definition ;
PRIVATE>
@ -275,18 +276,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
: :: (::) define ; parsing
! This will be cleaned up when method tuples and method words
! are unified
: create-method ( class generic -- method )
2dup method dup
[ 2nip ]
[ drop 2dup [ ] -rot define-method create-method ] if ;
: CREATE-METHOD ( -- class generic body )
scan-word bootstrap-word scan-word 2dup
create-method f set-word dup save-location ;
: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
: M:: (M::) define ; parsing
: MACRO:: (::) define-macro ; parsing

3
extra/logging/logging.factor
View File

@ -127,8 +127,7 @@ PRIVATE>
: LOG:
#! Syntax: name level
CREATE
dup reset-generic
CREATE-WORD
dup scan-word
[ >r >r 1array stack>message r> r> log-message ] 2curry
define ; parsing

6
extra/logging/server/server.factor
View File

@ -3,8 +3,8 @@
USING: namespaces kernel io calendar sequences io.files
io.sockets continuations prettyprint assocs math.parser
words debugger math combinators concurrency.messaging
threads arrays init math.ranges strings calendar.format
io.encodings.ascii ;
threads arrays init math.ranges strings calendar.format
io.encodings.utf8 ;
IN: logging.server
: log-root ( -- string )
@ -21,7 +21,7 @@ SYMBOL: log-files
: open-log-stream ( service -- stream )
log-path
dup make-directories
1 log# ascii <file-appender> ;
1 log# utf8 <file-appender> ;
: log-stream ( service -- stream )
log-files get [ open-log-stream ] cache ;

2
extra/memoize/memoize.factor
View File

@ -40,7 +40,7 @@ IN: memoize
over make-memoizer define ;
: MEMO:
CREATE dup reset-generic parse-definition define-memoized ; parsing
CREATE-WORD parse-definition define-memoized ; parsing
PREDICATE: word memoized "memoize" word-prop ;

2
extra/multiline/multiline.factor
View File

@ -18,7 +18,7 @@ IN: multiline
lexer get next-line ;
: STRING:
CREATE dup reset-generic
CREATE-WORD
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )

6
extra/namespaces/lib/lib-tests.factor Executable file
View File

@ -0,0 +1,6 @@
IN: namespaces.lib.tests
USING: namespaces.lib tools.test ;
[ ] [ [ ] { } nmake ] unit-test
[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test

24
extra/namespaces/lib/lib.factor Normal file → Executable file
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 ;
assocs.lib math.parser math sequences.lib locals ;
IN: namespaces.lib
@ -42,11 +42,19 @@ SYMBOL: building-seq
: 4% 4 n% ;
: 4# 4 n# ;
: nmake ( quot exemplars -- seqs )
dup length dup zero? [ 1+ ] when
[
MACRO:: nmake ( quot exemplars -- )
[let | n [ exemplars length ] |
[
[ drop 1024 swap new-resizable ] 2map
[ building-seq set call ] keep
] 2keep >r [ like ] 2map r> firstn
] with-scope ;
[
exemplars
[ 0 swap new-resizable ] map
building-seq set
quot call
building-seq get
exemplars [ like ] 2map
n firstn
] with-scope
]
] ;

85
extra/opengl/gl/gl-docs.factor Normal file
View File

@ -0,0 +1,85 @@
USING: help.syntax help.markup ;
IN: opengl.gl
ARTICLE: "opengl-low-level" "OpenGL Library (low level)"
{ $subsection "opengl-specifying-vertices" }
{ $subsection "opengl-geometric-primitives" }
{ $subsection "opengl-modeling-transformations" } ;
ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
{ $subsection glVertex2d }
{ $subsection glVertex2f }
{ $subsection glVertex2i }
{ $subsection glVertex2s }
{ $subsection glVertex3d }
{ $subsection glVertex3f }
{ $subsection glVertex3i }
{ $subsection glVertex3s }
{ $subsection glVertex4d }
{ $subsection glVertex4f }
{ $subsection glVertex4i }
{ $subsection glVertex4s }
{ $subsection glVertex2dv }
{ $subsection glVertex2fv }
{ $subsection glVertex2iv }
{ $subsection glVertex2sv }
{ $subsection glVertex3dv }
{ $subsection glVertex3fv }
{ $subsection glVertex3iv }
{ $subsection glVertex3sv }
{ $subsection glVertex4dv }
{ $subsection glVertex4fv }
{ $subsection glVertex4iv }
{ $subsection glVertex4sv } ;
ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
{ $table
{ { $link GL_POINTS } "individual points" }
{ { $link GL_LINES } { "pairs of vertices interpreted as "
"individual line segments" } }
{ { $link GL_LINE_STRIP } "series of connected line segments" }
{ { $link GL_LINE_LOOP } { "same as above, with a segment added "
"between last and first vertices" } }
{ { $link GL_TRIANGLES }
"triples of vertices interpreted as triangles" }
{ { $link GL_TRIANGLE_STRIP } "linked strip of triangles" }
{ { $link GL_TRIANGLE_FAN } "linked fan of triangles" }
{ { $link GL_QUADS }
"quadruples of vertices interpreted as four-sided polygons" }
{ { $link GL_QUAD_STRIP } "linked strip of quadrilaterals" }
{ { $link GL_POLYGON } "boundary of a simple, convex polygon" } }
;
HELP: glBegin
{ $values { "mode"
{ "One of the " { $link "opengl-geometric-primitives" } } } } ;
HELP: glPolygonMode
{ $values { "face" { "One of the following:"
{ $list { $link GL_FRONT }
{ $link GL_BACK }
{ $link GL_FRONT_AND_BACK } } } }
{ "mode" { "One of the following:"
{ $list
{ $link GL_POINT }
{ $link GL_LINE }
{ $link GL_FILL } } } } } ;
ARTICLE: "opengl-modeling-transformations" "Modeling Transformations"
{ $subsection glTranslatef }
{ $subsection glTranslated }
{ $subsection glRotatef }
{ $subsection glRotated }
{ $subsection glScalef }
{ $subsection glScaled } ;
{ glTranslatef glTranslated glRotatef glRotated glScalef glScaled }
related-words

6
extra/opengl/opengl-docs.factor
View File

@ -10,7 +10,11 @@ HELP: gl-error
{ $description "If the most recent OpenGL call resulted in an error, print the error to the " { $link stdio } " stream." } ;
HELP: do-state
{ $values { "what" integer } { "quot" quotation } }
{
$values
{ "mode" { "One of the " { $link "opengl-geometric-primitives" } } }
{ "quot" quotation }
}
{ $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ;
HELP: do-enabled

2
extra/opengl/opengl.factor
View File

@ -25,7 +25,7 @@ IN: opengl
"GL error: " over gluErrorString append throw
] unless drop ;
: do-state ( what quot -- )
: do-state ( mode quot -- )
swap glBegin call glEnd ; inline
: do-enabled ( what quot -- )

6
extra/openssl/libcrypto/libcrypto.factor
View File

@ -9,11 +9,13 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libcrypto
<<
"libcrypto" {
{ [ win32? ] [ "libeay32.dll" "stdcall" ] }
{ [ win32? ] [ "libeay32.dll" "cdecl" ] }
{ [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libcrypto.so" "cdecl" ] }
{ [ unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
>>
C-STRUCT: bio-method
{ "int" "type" }

4
extra/openssl/libssl/libssl.factor Normal file → Executable file
View File

@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libssl
<< "libssl" {
{ [ win32? ] [ "ssleay32.dll" "stdcall" ] }
{ [ win32? ] [ "ssleay32.dll" "cdecl" ] }
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
{ [ unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
: X509_FILETYPE_PEM 1 ; inline

38
extra/openssl/openssl-tests.factor
View File

@ -21,55 +21,55 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
! Initialize context
! =========================================================
init load-error-strings
[ ] [ init load-error-strings ] unit-test
ssl-v23 new-ctx
[ ] [ ssl-v23 new-ctx ] unit-test
get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain
[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
get-ctx "password" string>char-alien set-default-passwd-userdata
[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password
get-ctx "/extra/openssl/test/server.pem" resource-path
SSL_FILETYPE_PEM use-private-key
[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path
SSL_FILETYPE_PEM use-private-key ] unit-test
get-ctx "/extra/openssl/test/root.pem" resource-path f
verify-load-locations
[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f
verify-load-locations ] unit-test
get-ctx 1 set-verify-depth
[ ] [ get-ctx 1 set-verify-depth ] unit-test
! =========================================================
! Load Diffie-Hellman parameters
! =========================================================
"/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file
[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
get-bio f f f read-pem-dh-params
[ ] [ get-bio f f f read-pem-dh-params ] unit-test
get-bio bio-free
[ ] [ get-bio bio-free ] unit-test
! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol'
! get-ctx get-dh set-tmp-dh-callback
[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test
! Workaround (this function should never be called directly)
get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl
! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test
! =========================================================
! Generate ephemeral RSA key
! =========================================================
512 RSA_F4 f f generate-rsa-key
[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test
! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol'
! get-ctx get-rsa set-tmp-rsa-callback
! Workaround (this function should never be called directly)
get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl
[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test
get-rsa free-rsa
[ ] [ get-rsa free-rsa ] unit-test
! =========================================================
! Listen and accept on socket
@ -129,11 +129,11 @@ get-rsa free-rsa
! Dump errors to file
! =========================================================
"/extra/openssl/test/errors.txt" resource-path "w" bio-new-file
[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
get-bio bio-free
[ ] [ get-bio bio-free ] unit-test
! =========================================================
! Clean-up

2
extra/promises/promises.factor
View File

@ -40,6 +40,6 @@ TUPLE: promise quot forced? value ;
] [ ] make ;
: LAZY:
CREATE dup reset-generic
CREATE-WORD
dup parse-definition
make-lazy-quot define ; parsing

174
extra/reports/noise/noise.factor Executable file
View File

@ -0,0 +1,174 @@
USING: assocs math kernel shuffle combinators.lib
words quotations arrays combinators sequences math.vectors
io.styles combinators.cleave prettyprint vocabs sorting io
generic locals.private math.statistics ;
IN: reports.noise
: badness ( word -- n )
H{
{ -nrot 5 }
{ -roll 4 }
{ -rot 3 }
{ 2apply 1 }
{ 2curry 1 }
{ 2drop 1 }
{ 2dup 1 }
{ 2keep 1 }
{ 2nip 2 }
{ 2over 4 }
{ 2slip 2 }
{ 2swap 3 }
{ 2with 2 }
{ 2with* 3 }
{ 3apply 1/2 }
{ 3curry 2 }
{ 3drop 1 }
{ 3dup 2 }
{ 3keep 3 }
{ 3nip 4 }
{ 3slip 3 }
{ 3with 3 }
{ 3with* 4 }
{ 4drop 2 }
{ 4dup 3 }
{ 4slip 4 }
{ compose 1/2 }
{ curry 1/3 }
{ dip 1 }
{ dipd 2 }
{ drop 1/3 }
{ dup 1/3 }
{ if 1/3 }
{ when 1/4 }
{ unless 1/4 }
{ when* 1/3 }
{ unless* 1/3 }
{ ?if 1/2 }
{ cond 1/2 }
{ case 1/2 }
{ keep 1 }
{ napply 2 }
{ ncurry 3 }
{ ndip 5 }
{ ndrop 2 }
{ ndup 3 }
{ nip 2 }
{ nipd 3 }
{ nkeep 5 }
{ npick 6 }
{ nrev 5 }
{ nrot 5 }
{ nslip 5 }
{ ntuck 6 }
{ nwith 4 }
{ over 2 }
{ pick 4 }
{ roll 4 }
{ rot 3 }
{ slip 1 }
{ spin 3 }
{ swap 1 }
{ swapd 3 }
{ tuck 2 }
{ tuckd 4 }
{ with 1/2 }
{ with* 2 }
{ r> 1 }
{ >r 1 }
{ bi 1/2 }
{ tri 1 }
{ bi* 1/2 }
{ tri* 1 }
{ cleave 2 }
{ spread 2 }
} at 0 or ;
: vsum { 0 0 } [ v+ ] reduce ;
GENERIC: noise ( obj -- pair )
M: word noise badness 1 2array ;
M: wrapper noise wrapped noise ;
M: let noise let-body noise ;
M: wlet noise wlet-body noise ;
M: lambda noise lambda-body noise ;
M: object noise drop { 0 0 } ;
M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
M: array noise [ noise ] map vsum ;
: noise-factor / 100 * >integer ;
: quot-noise-factor ( quot -- n )
#! For very short words, noise doesn't count so much
#! (so dup foo swap bar isn't penalized as badly).
noise first2 {
{ [ over 4 <= ] [ >r drop 0 r> ] }
{ [ over 15 >= ] [ >r 2 * r> ] }
{ [ t ] [ ] }
} cond
{
! short words are easier to read
{ [ dup 10 <= ] [ >r 2 / r> ] }
{ [ dup 5 <= ] [ >r 3 / r> ] }
! long words are penalized even more
{ [ dup 25 >= ] [ >r 2 * r> 20 max ] }
{ [ dup 20 >= ] [ >r 5/3 * r> ] }
{ [ dup 15 >= ] [ >r 3/2 * r> ] }
{ [ t ] [ ] }
} cond noise-factor ;
GENERIC: word-noise-factor ( word -- factor )
M: word word-noise-factor
word-def quot-noise-factor ;
M: lambda-word word-noise-factor
"lambda" word-prop quot-noise-factor ;
: flatten-generics ( words -- words' )
[
dup generic? [ methods values ] [ 1array ] if
] map concat ;
: noisy-words ( -- alist )
all-words flatten-generics
[ dup word-noise-factor ] { } map>assoc
sort-values reverse ;
: noise. ( alist -- )
standard-table-style [
[
[ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
] assoc-each
] tabular-output ;
: vocab-noise-factor ( vocab -- factor )
words flatten-generics
[ word-noise-factor dup 20 < [ drop 0 ] when ] map
dup empty? [ drop 0 ] [
[ [ sum ] [ length 5 max ] bi /i ]
[ supremum ]
bi +
] if ;
: noisy-vocabs ( -- alist )
vocabs [ dup vocab-noise-factor ] { } map>assoc
sort-values reverse ;
: noise-report ( -- )
"NOISY WORDS:" print
noisy-words 80 head noise.
nl
"NOISY VOCABS:" print
noisy-vocabs 80 head noise. ;
MAIN: noise-report

33
extra/reports/optimizer/optimizer.factor Executable file
View File

@ -0,0 +1,33 @@
USING: assocs words sequences arrays compiler tools.time
io.styles io prettyprint vocabs kernel sorting generator
optimizer math combinators.cleave ;
IN: report.optimizer
: count-optimization-passes ( nodes n -- n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
: results
[ [ second ] swap compose compare ] curry sort 20 tail*
print
standard-table-style
[
[ [ [ pprint-cell ] each ] with-row ] each
] tabular-output ; inline
: optimizer-measurements ( -- alist )
all-words [ compiled? ] subset
[
dup [
word-dataflow nip 1 count-optimization-passes
] benchmark nip 2array
] { } map>assoc ;
: optimizer-measurements. ( alist -- )
[ [ first ] "Worst number of optimizer passes:" results ]
[ [ second ] "Worst compile times:" results ] bi ;
: optimizer-report ( -- )
optimizer-measurements optimizer-measurements. ;
MAIN: optimizer-report

3
extra/sequences/lib/lib-tests.factor
View File

@ -79,3 +79,6 @@ IN: sequences.lib.tests
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test

Some files were not shown because too many files have changed in this diff Show More