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

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

db4
Joe Groff 2008-03-18 23:02:44 -07:00
parent 46c21e2580 d04eb777ff
commit 11d28109cf
95 changed files with 1133 additions and 572 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\"" } } }

10
core/alien/alien-tests.factor
View File

@ -1,7 +1,7 @@
IN: alien.tests
USING: alien alien.accessors byte-arrays arrays kernel
kernel.private namespaces tools.test sequences libc math system
prettyprint layouts ;
USING: alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
system prettyprint layouts ;
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
@ -68,3 +68,7 @@ cell 8 = [
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test

2
core/alien/alien.factor
View File

@ -58,7 +58,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 ]

2
core/alien/syntax/syntax.factor
View File

@ -32,7 +32,7 @@ PRIVATE>
>r >r swapd roll indirect-quot r> r>
-rot define-declared ;
: DLL" skip-blank parse-string dlopen parsed ; parsing
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
: ALIEN: scan string>number <alien> parsed ; parsing

6
core/bootstrap/primitives.factor
View File

@ -87,11 +87,7 @@ call
"words.private"
"vectors"
"vectors.private"
} [
dup find-vocab-root swap create-vocab
[ set-vocab-root ] keep
f swap set-vocab-source-loaded?
] each
} [ create-vocab drop ] each
H{ } clone source-files set
H{ } clone class<map set

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/bootstrap/syntax.factor
View File

@ -3,9 +3,7 @@
USING: words sequences vocabs kernel ;
IN: bootstrap.syntax
"syntax" create-vocab
"resource:core" over set-vocab-root
f swap set-vocab-source-loaded?
"syntax" create-vocab drop
{
"!"

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

@ -28,6 +28,8 @@ TUPLE: second-one ;
UNION: both first-one union-class ;
[ t ] [ both tuple classes-intersect? ] unit-test
[ null ] [ vector virtual-sequence class-and ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test

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" } }

28
core/generic/generic-tests.factor
View File

@ -238,3 +238,31 @@ M: sequence generic-forget-test-2 = ;
\ = usage [ word? ] subset
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
GENERIC: generic-forget-test-3
M: f generic-forget-test-3 ;
[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ f ] [ f generic-forget-test-3 ] unit-test
: a-word ;
GENERIC: a-generic
M: integer a-generic a-word ;
[ ] [ \ integer \ a-generic method "m" set ] unit-test
[ t ] [ "m" get \ a-word usage memq? ] unit-test
[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
[ f ] [ "m" get \ a-word usage memq? ] unit-test

79
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,30 +98,31 @@ 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
[ delete-at* ] with-methods
[ forget-word ] [ drop ] if ;
dup generic? [
[ delete-at* ] with-methods
[ forget-word ] [ drop ] if
] [
2drop
] if ;
M: method-spec forget*
first2 forget-method ;
first2 method 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
forget-method ;
dup "forgotten" word-prop [ drop ] [
dup "method-class" word-prop
over "method-generic" word-prop forget-method
t "forgotten" set-word-prop
] if ;
: implementors* ( classes -- words )
all-words [
@ -163,16 +154,12 @@ M: assoc update-methods ( assoc -- )
make-generic
] if ;
GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
M: generic subwords
dup "methods" word-prop values
swap "default-method" word-prop add ;
M: generic forget-word
dup subwords [ forget-word ] each (forget-word) ;
dup subwords [ forget ] each (forget-word) ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;

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

6
core/inference/class/class-tests.factor
View File

@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts ;
system layouts vectors ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -294,4 +294,6 @@ cell-bits 32 = [
\ >= inlined?
] unit-test
[ t ] [
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
] unit-test

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

@ -86,16 +86,10 @@ 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
@ -222,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 ;

2
core/io/streams/c/c-docs.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.files threads
strings byte-arrays io.streams.lines io.streams.plain ;
strings byte-arrays io.streams.plain ;
IN: io.streams.c
ARTICLE: "io.streams.c" "ANSI C streams"

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 ;

56
core/parser/parser-tests.factor
View File

@ -1,7 +1,7 @@
USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting tuples compiler.units debugger ;
sorting tuples compiler.units debugger vocabs.loader ;
IN: parser.tests
[
@ -397,35 +397,47 @@ IN: parser.tests
] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
[
"redefining-a-class-5" forget-source
"redefining-a-class-6" forget-source
"redefining-a-class-7" forget-source
] with-compilation-unit
] unit-test
[ ] [
"IN: parser.tests M: f foo ;"
<string-reader> "redefining-a-class-6" parse-stream drop
] unit-test
2 [
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [
"IN: parser.tests M: f foo ;"
<string-reader> "redefining-a-class-6" parse-stream drop
] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ;"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ;"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
] times
[ "resource:core/parser/test/assert-depth.factor" run-file ]
[ relative-overflow-stack { 1 2 3 } sequence= ]
@ -447,3 +459,5 @@ must-fail-with
<string-reader> "d-f-s-test" parse-stream drop
] unit-test
] times
[ ] [ "parser" reload ] unit-test

30
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 )
@ -466,7 +478,15 @@ SYMBOL: interactive-vocabs
: smudged-usage ( -- usages referenced removed )
removed-definitions filter-moved keys [
outside-usages
[ empty? swap pathname? or not ] assoc-subset
[
empty? [ drop f ] [
{
{ [ dup pathname? ] [ f ] }
{ [ dup method-body? ] [ f ] }
{ [ t ] [ t ] }
} cond nip
] if
] assoc-subset
dup values concat prune swap keys
] keep ;

12
core/prettyprint/prettyprint-tests.factor
View File

@ -317,3 +317,15 @@ unit-test
[ ] [ 1 \ + curry unparse drop ] unit-test
[ ] [ 1 \ + compose unparse drop ] unit-test
GENERIC: generic-see-test-with-f ( obj -- obj )
M: f generic-see-test-with-f ;
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
[ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
] unit-test
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
[ \ f \ generic-see-test-with-f method see ] with-string-writer
] unit-test

6
core/prettyprint/prettyprint.factor
View File

@ -172,13 +172,13 @@ M: hook-generic synopsis*
stack-effect. ;
M: method-spec synopsis*
dup definer. [ pprint-word ] each ;
first2 method synopsis* ;
M: method-body synopsis*
dup dup
definer.
"method-class" word-prop pprint*
"method-generic" word-prop pprint* ;
"method-class" word-prop pprint-word
"method-generic" word-prop pprint-word ;
M: mixin-instance synopsis*
dup definer.

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" } }

9
core/vocabs/loader/loader-tests.factor
View File

@ -78,6 +78,8 @@ IN: vocabs.loader.tests
] with-compilation-unit
] unit-test
[ f ] [ "vocabs.loader.test.b" vocab-files empty? ] unit-test
[ ] [
[
"vocabs.loader.test.b" vocab-files
@ -118,6 +120,13 @@ IN: vocabs.loader.tests
[ { "resource:core/kernel/kernel.factor" 1 } ]
[ "kernel" vocab where ] unit-test
[ ] [
[
"vocabs.loader.test.c" forget-vocab
"vocabs.loader.test.d" forget-vocab
] with-compilation-unit
] unit-test
[ t ] [
[ "vocabs.loader.test.d" require ] [ :1 ] recover
"vocabs.loader.test.d" vocab-source-loaded?

59
core/vocabs/loader/loader.factor
View File

@ -43,7 +43,7 @@ V{
vocab-roots get swap [ vocab-dir? ] curry find nip ;
M: string vocab-root
dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
vocab dup [ vocab-root ] when ;
M: vocab-link vocab-root
vocab-link-root ;
@ -66,24 +66,22 @@ SYMBOL: load-help?
: load-docs ( vocab -- )
load-help? get [
[ docs-weren't-loaded ] keep
[ vocab-docs-path ?run-file ] keep
[ vocab-docs-path [ ?run-file ] when* ] keep
docs-were-loaded
] [ drop ] if ;
: create-vocab-with-root ( vocab-link -- vocab )
dup vocab-name create-vocab
swap vocab-root over set-vocab-root ;
: create-vocab-with-root ( name root -- vocab )
swap create-vocab [ set-vocab-root ] keep ;
: update-root ( vocab -- )
dup vocab-root
[ drop ] [ dup find-vocab-root swap set-vocab-root ] if ;
: reload ( name -- )
[
f >vocab-link
dup vocab-root [
dup vocab-source-path resource-exists? [
create-vocab-with-root
dup load-source
load-docs
] [ no-vocab ] if
] [ no-vocab ] if
dup vocab [
dup update-root dup load-source load-docs
] [ no-vocab ] ?if
] with-compiler-errors ;
: require ( vocab -- )
@ -100,33 +98,38 @@ SYMBOL: load-help?
SYMBOL: blacklist
GENERIC: (load-vocab) ( name -- vocab )
: add-to-blacklist ( error vocab -- )
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
GENERIC: (load-vocab) ( name -- )
M: vocab (load-vocab)
[
dup vocab-root [
dup update-root
dup vocab-root [
[
dup vocab-source-loaded? [ dup load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless
] when
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
] [ [ swap add-to-blacklist ] keep rethrow ] recover
] when drop ;
M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ;
! ".private" ?tail drop
dup find-vocab-root >vocab-link (load-vocab) ;
M: vocab-link (load-vocab)
vocab-name (load-vocab) ;
dup vocab-name swap vocab-root dup
[ create-vocab-with-root (load-vocab) ] [ 2drop ] if ;
[
dup vocab-name blacklist get at* [
rethrow
] [
drop
[ dup vocab swap or (load-vocab) ] with-compiler-errors
] if
[
dup vocab-name blacklist get at* [
rethrow
] [
drop
[ (load-vocab) ] with-compiler-errors
] if
] with-compiler-errors
] load-vocab-hook set-global
: vocab-where ( vocab -- loc )

20
core/vocabs/vocabs.factor
View File

@ -15,8 +15,8 @@ source-loaded? docs-loaded? ;
M: vocab equal? 2drop f ;
: <vocab> ( name -- vocab )
H{ } clone t
{ set-vocab-name set-vocab-words set-vocab-source-loaded? }
H{ } clone
{ set-vocab-name set-vocab-words }
\ vocab construct ;
GENERIC: vocab ( vocab-spec -- vocab )
@ -60,9 +60,16 @@ M: f vocab-help ;
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
SYMBOL: load-vocab-hook
TUPLE: no-vocab name ;
: load-vocab ( name -- vocab ) load-vocab-hook get call ;
: no-vocab ( name -- * )
vocab-name \ no-vocab construct-boa throw ;
SYMBOL: load-vocab-hook ! ( name -- )
: load-vocab ( name -- vocab )
dup load-vocab-hook get call
dup vocab [ ] [ no-vocab ] ?if ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;
@ -115,8 +122,3 @@ UNION: vocab-spec vocab vocab-link ;
vocab-name dictionary get delete-at ;
M: vocab-spec forget* forget-vocab ;
TUPLE: no-vocab name ;
: no-vocab ( name -- * )
vocab-name \ no-vocab construct-boa throw ;

7
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 ;
@ -169,7 +169,12 @@ SYMBOL: changed-words
"declared-effect" "constructor-quot" "delimiter"
} reset-props ;
GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
: reset-generic ( word -- )
dup subwords [ forget ] each
dup reset-word
{ "methods" "combination" "default-method" } reset-props ;

7
extra/bootstrap/help/help.factor
View File

@ -9,11 +9,10 @@ IN: bootstrap.help
t load-help? set-global
[ vocab ] load-vocab-hook [
[ drop ] load-vocab-hook [
vocabs
[ vocab-root ] subset
[ vocab-source-loaded? ] subset
[ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
[ vocab-docs-loaded? not ] subset
[ load-docs ] each
] with-variable ;
load-help

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 )

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

@ -22,11 +22,11 @@ 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 ;
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 ;
: create-surface ( gadget -- cairo_surface_t )
make-image-array
@ -60,8 +60,8 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
M: cairo-gadget graft* ( gadget -- )
dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
! M: cairo-gadget ungraft* ( gadget -- )
! cairo-gadget-cairo-t cairo_destroy ;
M: cairo-gadget ungraft* ( gadget -- )
cairo-gadget-cairo-t cairo_destroy ;
: <cairo-gadget> ( -- gadget )
cairo-gadget construct-gadget ;

3
extra/core-foundation/fsevents/fsevents.factor
View File

@ -150,7 +150,8 @@ SYMBOL: event-stream-callbacks
: event-stream-counter \ event-stream-counter counter ;
[
H{ } clone event-stream-callbacks set-global
event-stream-callbacks global
[ [ drop expired? not ] assoc-subset ] change-at
1 \ event-stream-counter set-global
] "core-foundation" add-init-hook

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

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

9
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 ] }
@ -106,6 +106,8 @@ IN: db.sqlite.lib
: 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
@ -119,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 ] }
@ -131,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 ]
@ -140,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
] [

28
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 ;
@ -22,6 +23,8 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
INSTANCE: sqlite-statement throwable-statement
TUPLE: sqlite-result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
@ -33,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 ;
@ -46,9 +57,12 @@ M: sqlite-result-set dispose ( result-set -- )
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- ) statement-handle sqlite-reset ;
: 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 ;
@ -89,6 +103,7 @@ 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 ;
@ -125,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 -- )
@ -175,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" }
@ -193,6 +210,7 @@ M: sqlite-db compound-type ( str seq -- str' )
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
{ +random-id+ "integer primary key" }
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }

45
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
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
! [ native-person-schema test-tuples ] test-postgresql
! [ assigned-person-schema test-tuples ] test-postgresql
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
TUPLE: serialize-me id data ;
@ -240,8 +240,33 @@ TUPLE: exam id name score ;
! [ test-ranges ] test-sqlite
\ insert-tuple must-infer
\ update-tuple must-infer
\ delete-tuple must-infer
\ select-tuple must-infer
\ define-persistent must-infer
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

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

2
extra/fry/fry-docs.factor
View File

@ -46,7 +46,7 @@ $nl
}
"The " { $link , } " and " { $link @ } " specifiers may be freely mixed:"
{ $code
"{ 8 13 14 27 } [ even? ] 5 [ @ dup , ? ] map"
"{ 8 13 14 27 } [ even? ] 5 '[ @ dup , ? ] map"
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}

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

3
extra/help/markup/markup.factor
View File

@ -158,7 +158,8 @@ M: f print-element drop ;
: $subsection ( element -- )
[ first ($long-link) ] ($subsection) ;
: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
: ($vocab-link) ( text vocab -- )
dup vocab-root >vocab-link write-link ;
: $vocab-subsection ( element -- )
[

1
extra/help/stylesheet/stylesheet.factor
View File

@ -82,6 +82,7 @@ H{
{ page-color { 0.95 0.95 0.95 1 } }
{ border-color { 1 0 0 1 } }
{ border-width 5 }
{ wrap-margin 500 }
} warning-style set-global
SYMBOL: table-content-style

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

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

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

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

@ -7,16 +7,29 @@ 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
SYMBOL: post-login-url
SYMBOL: login-failed?
TUPLE: login users ;
: users login get users>> ;
SYMBOL: post-login-url
SYMBOL: login-failed?
! 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
@ -116,6 +129,8 @@ SYMBOL: user-exists?
] unless*
successful-login
login get responder>> init-user-profile
] >>submit
] ;
@ -155,23 +170,21 @@ SYMBOL: previous-page
form validate-form
logged-in-user sget
"password" value empty? [
logged-in-user sget
] [
same-password-twice
"password" value uid users check-login
[ login-failed? on validation-failed ] unless
"new-password" value uid users set-password
[ "User deleted" throw ] unless*
] if
"new-password" value set-password
] unless
"realname" value >>realname
"email" value >>email
dup users update-user
logged-in-user sset
user-profile-changed? on
previous-page sget f <permanent-redirect>
] >>submit
@ -330,6 +343,7 @@ C: <protected> protected
M: protected call-responder ( path responder -- response )
logged-in-user sget [
dup save-user-after
request get request-url previous-page sset
responder>> call-responder
] [

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

@ -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 >boolean ] unit-test
[ ] [ "user" get "fdasf" set-password drop ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test

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

@ -12,26 +12,28 @@ users-in-db "provider" set
[ 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 >boolean ] 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

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 -- user/f )
[let | user [ username provider get-user ] |
user [
user
password >>password
dup provider update-user
] [ f ] if
] ;
: set-password ( user password -- user ) >>password ;
! Password recovery support

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

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

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

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

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

@ -1,8 +1,8 @@
IN: http.server.sessions.tests
USING: tools.test http http.server.sessions
http.server.sessions.storage http.server.sessions.storage.assoc
http.server math namespaces kernel accessors prettyprint
io.streams.string splitting destructors ;
http.server.actions http.server math namespaces kernel accessors
prettyprint io.streams.string splitting destructors sequences ;
[ H{ } ] [ H{ } add-session-id ] unit-test
@ -72,9 +72,9 @@ M: foo call-responder
: url-responder-mock-test
[
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
@ -107,9 +107,9 @@ response set
: cookie-responder-mock-test
[
<request>
"GET" >>method
"cookies" get >>cookies
"/" >>path
"GET" >>method
"cookies" get >>cookies
"/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
@ -118,3 +118,28 @@ response set
[ "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

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

@ -13,7 +13,7 @@ IN: http.server.sessions
GENERIC: init-session* ( responder -- )
M: dispatcher init-session* drop ;
M: object init-session* drop ;
TUPLE: session-manager responder sessions ;
@ -56,8 +56,11 @@ M: session-saver dispose
sessions update-session
] [ drop ] if ;
: save-session-after ( id session -- )
<session-saver> add-always-destructor ;
: call-responder/session ( path responder id session -- response )
[ <session-saver> add-always-destructor ]
[ save-session-after ]
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ;

14
extra/http/server/sessions/storage/db/db.factor
View File

@ -21,23 +21,18 @@ session "SESSIONS"
session construct-empty
swap dup [ string>number ] when >>id ;
USING: namespaces io prettyprint ;
M: sessions-in-db get-session ( id storage -- namespace/f )
global [ "get " write over print flush ] bind
drop
dup [
<session>
select-tuple dup [ namespace>> ] when global [ dup . ] bind
select-tuple dup [ namespace>> ] when
] when ;
M: sessions-in-db update-session ( namespace id storage -- )
global [ "update " write over print flush ] bind
drop
<session>
swap global [ dup . ] bind >>namespace
dup update-tuple
id>> <session> select-tuple global [ . flush ] bind
;
swap >>namespace
update-tuple ;
M: sessions-in-db delete-session ( id storage -- )
drop
@ -45,8 +40,7 @@ M: sessions-in-db delete-session ( id storage -- )
delete-tuple ;
M: sessions-in-db new-session ( namespace storage -- id )
global [ "new " print flush ] bind
drop
f <session>
swap global [ dup . ] bind >>namespace
swap >>namespace
[ insert-tuple ] [ id>> number>string ] bi ;

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

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

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 )

17
extra/opengl/gl/gl-docs.factor
View File

@ -5,7 +5,8 @@ IN: opengl.gl
ARTICLE: "opengl-low-level" "OpenGL Library (low level)"
{ $subsection "opengl-specifying-vertices" }
{ $subsection "opengl-geometric-primitives" } ;
{ $subsection "opengl-geometric-primitives" }
{ $subsection "opengl-modeling-transformations" } ;
ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
@ -68,3 +69,17 @@ HELP: glPolygonMode
{ $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

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

@ -11,7 +11,7 @@ IN: openssl.libcrypto
<<
"libcrypto" {
{ [ win32? ] [ "libeay32.dll" "stdcall" ] }
{ [ win32? ] [ "libeay32.dll" "cdecl" ] }
{ [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
{ [ unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library

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

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

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

30
extra/serialize/serialize-tests.factor
View File

@ -4,7 +4,7 @@
USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
classes math.constants io.encodings.binary random
combinators.lib ;
combinators.lib assocs ;
IN: serialize.tests
: test-serialize-cell
@ -56,19 +56,23 @@ C: <serialize-test> serialize-test
} ;
: check-serialize-1 ( obj -- ? )
"=====" print
dup class .
dup .
dup
binary [ serialize ] with-byte-writer
binary [ deserialize ] with-byte-reader = ;
object>bytes
bytes>object
dup . = ;
: check-serialize-2 ( obj -- ? )
dup number? over wrapper? or [
drop t ! we don't care if numbers aren't interned
] [
"=====" print
dup class .
dup 2array
binary [ serialize ] with-byte-writer
binary [ deserialize ] with-byte-reader
dup 2array dup .
object>bytes
bytes>object dup .
first2 eq?
] if ;
@ -79,3 +83,17 @@ C: <serialize-test> serialize-test
[ t ] [ pi check-serialize-1 ] unit-test
[ serialize ] must-infer
[ deserialize ] must-infer
[ t ] [
V{ } dup dup push
object>bytes
bytes>object
dup first eq?
] unit-test
[ t ] [
H{ } dup dup dup set-at
object>bytes
bytes>object
dup keys first eq?
] unit-test

216
extra/serialize/serialize.factor
View File

@ -6,13 +6,14 @@
!
! See http://factorcode.org/license.txt for BSD license.
!
IN: serialize
USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs tuples arrays
vectors byte-arrays bit-arrays quotations hashtables
assocs help.syntax help.markup float-arrays splitting
io.encodings.string io.encodings.utf8 combinators new-slots
accessors ;
io.binary strings classes words sbufs tuples arrays vectors
byte-arrays bit-arrays quotations hashtables assocs help.syntax
help.markup float-arrays splitting io.streams.byte-array
io.encodings.string io.encodings.utf8 io.encodings.binary
combinators combinators.cleave new-slots accessors locals
prettyprint compiler.units sequences.private tuples.private ;
IN: serialize
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
@ -69,7 +70,8 @@ GENERIC: (serialize) ( obj -- )
: serialize-shared ( obj quot -- )
>r dup object-id
[ CHAR: o write1 serialize-cell drop ] r> if* ; inline
[ CHAR: o write1 serialize-cell drop ]
r> if* ; inline
M: f (serialize) ( obj -- )
drop CHAR: n write1 ;
@ -96,75 +98,93 @@ M: ratio (serialize) ( obj -- )
dup numerator (serialize)
denominator (serialize) ;
: serialize-string ( obj code -- )
write1
dup utf8 encode dup length serialize-cell write
add-object ;
M: string (serialize) ( obj -- )
[ CHAR: s serialize-string ] serialize-shared ;
: serialize-elements ( seq -- )
[ (serialize) ] each CHAR: . write1 ;
: serialize-seq ( obj code -- )
[
write1
[ add-object ]
[ length serialize-cell ]
[ [ (serialize) ] each ] tri
] curry serialize-shared ;
M: tuple (serialize) ( obj -- )
[
CHAR: T write1
dup tuple>array serialize-elements
add-object
[ class (serialize) ]
[ add-object ]
[ tuple>array 1 tail (serialize) ]
tri
] serialize-shared ;
: serialize-seq ( seq code -- )
[
write1
dup serialize-elements
add-object
] curry serialize-shared ;
M: array (serialize) ( obj -- )
CHAR: a serialize-seq ;
M: byte-array (serialize) ( obj -- )
[
CHAR: A write1
dup dup length serialize-cell write
add-object
] serialize-shared ;
M: bit-array (serialize) ( obj -- )
[
CHAR: b write1
dup length serialize-cell
dup [ 1 0 ? ] B{ } map-as write
add-object
] serialize-shared ;
M: quotation (serialize) ( obj -- )
CHAR: q serialize-seq ;
M: float-array (serialize) ( obj -- )
[
CHAR: f write1
dup length serialize-cell
dup [ double>bits 8 >be write ] each
add-object
CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
] serialize-shared ;
M: hashtable (serialize) ( obj -- )
[
CHAR: h write1
dup >alist (serialize)
add-object
[ add-object ] [ >alist (serialize) ] bi
] serialize-shared ;
M: word (serialize) ( obj -- )
M: bit-array (serialize) ( obj -- )
CHAR: b serialize-seq ;
M: byte-array (serialize) ( obj -- )
[
CHAR: w write1
dup word-name (serialize)
dup word-vocabulary (serialize)
add-object
CHAR: A write1
[ add-object ]
[ length serialize-cell ]
[ write ] tri
] serialize-shared ;
M: float-array (serialize) ( obj -- )
[
CHAR: f write1
[ add-object ]
[ length serialize-cell ]
[ [ double>bits 8 >be write ] each ]
tri
] serialize-shared ;
M: string (serialize) ( obj -- )
[
CHAR: s write1
[ add-object ]
[
utf8 encode
[ length serialize-cell ]
[ write ] bi
] bi
] serialize-shared ;
: serialize-true ( word -- )
drop CHAR: t write1 ;
: serialize-gensym ( word -- )
[
CHAR: G write1
[ add-object ]
[ word-def (serialize) ]
[ word-props (serialize) ]
tri
] serialize-shared ;
: serialize-word ( word -- )
CHAR: w write1
[ word-name (serialize) ]
[ word-vocabulary (serialize) ]
bi ;
M: word (serialize) ( obj -- )
{
{ [ dup t eq? ] [ serialize-true ] }
{ [ dup word-vocabulary not ] [ serialize-gensym ] }
{ [ t ] [ serialize-word ] }
} cond ;
M: wrapper (serialize) ( obj -- )
CHAR: W write1
wrapped (serialize) ;
@ -179,6 +199,9 @@ SYMBOL: deserialized
: deserialize-false ( -- f )
f ;
: deserialize-true ( -- f )
t ;
: deserialize-positive-integer ( -- number )
deserialize-cell ;
@ -204,53 +227,63 @@ SYMBOL: deserialized
(deserialize-string) dup intern-object ;
: deserialize-word ( -- word )
(deserialize) dup (deserialize) lookup
[ dup intern-object ] [ "Unknown word" throw ] ?if ;
(deserialize) (deserialize) 2dup lookup
dup [ 2nip ] [
"Unknown word: " -rot
2array unparse append throw
] if ;
: deserialize-gensym ( -- word )
gensym
dup intern-object
dup (deserialize) define
dup (deserialize) swap set-word-props ;
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
SYMBOL: +stop+
: (deserialize-seq) ( -- seq )
[ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
: deserialize-seq ( seq -- array )
>r (deserialize-seq) r> like dup intern-object ;
:: (deserialize-seq) ( exemplar quot -- seq )
deserialize-cell exemplar new
[ intern-object ]
[ dup [ drop quot call ] change-each ] bi ; inline
: deserialize-array ( -- array )
{ } deserialize-seq ;
{ } [ (deserialize) ] (deserialize-seq) ;
: deserialize-quotation ( -- array )
[ ] deserialize-seq ;
: (deserialize-byte-array) ( -- byte-array )
deserialize-cell read B{ } like ;
(deserialize) >quotation dup intern-object ;
: deserialize-byte-array ( -- byte-array )
(deserialize-byte-array) dup intern-object ;
B{ } [ read1 ] (deserialize-seq) ;
: deserialize-bit-array ( -- bit-array )
(deserialize-byte-array) [ 0 > ] ?{ } map-as
dup intern-object ;
?{ } [ (deserialize) ] (deserialize-seq) ;
: deserialize-float-array ( -- float-array )
deserialize-cell
8 * read 8 <groups> [ be> bits>double ] F{ } map-as
dup intern-object ;
F{ } [ 8 read be> bits>double ] (deserialize-seq) ;
: deserialize-hashtable ( -- hashtable )
(deserialize) >hashtable dup intern-object ;
H{ } clone
[ intern-object ]
[ (deserialize) update ]
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
>r dup length [ 1+ ] map r> [ set-array-nth ] curry 2each ;
: deserialize-tuple ( -- array )
(deserialize-seq) >tuple dup intern-object ;
#! Ugly because we have to intern the tuple before reading
#! slots
(deserialize) construct-empty
[ intern-object ]
[
[ (deserialize) ]
[ [ copy-seq-to-tuple ] keep ] bi*
] bi ;
: deserialize-unknown ( -- object )
deserialize-cell deserialized get nth ;
: deserialize-stop ( -- object )
+stop+ get ;
: deserialize* ( -- object ? )
read1 [
{
@ -265,14 +298,15 @@ SYMBOL: +stop+
{ CHAR: h [ deserialize-hashtable ] }
{ CHAR: m [ deserialize-negative-integer ] }
{ CHAR: n [ deserialize-false ] }
{ CHAR: t [ deserialize-true ] }
{ CHAR: o [ deserialize-unknown ] }
{ CHAR: p [ deserialize-positive-integer ] }
{ CHAR: q [ deserialize-quotation ] }
{ CHAR: r [ deserialize-ratio ] }
{ CHAR: s [ deserialize-string ] }
{ CHAR: w [ deserialize-word ] }
{ CHAR: G [ deserialize-word ] }
{ CHAR: z [ deserialize-zero ] }
{ CHAR: . [ deserialize-stop ] }
} case t
] [
f f
@ -282,14 +316,16 @@ SYMBOL: +stop+
deserialize* [ "End of stream" throw ] unless ;
: deserialize ( -- obj )
[
V{ } clone deserialized set
gensym +stop+ set
(deserialize)
] with-scope ;
! [
V{ } clone deserialized
[ (deserialize) ] with-variable ;
! ] with-compilation-unit ;
: serialize ( obj -- )
[
H{ } clone serialized set
(serialize)
] with-scope ;
H{ } clone serialized [ (serialize) ] with-variable ;
: bytes>object ( bytes -- obj )
binary [ deserialize ] with-byte-reader ;
: object>bytes ( obj -- bytes )
binary [ serialize ] with-byte-writer ;

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

@ -133,9 +133,10 @@ IN: tools.deploy.shaker
strip-io? [ io.backend:io-backend , ] when
[
io.backend:io-backend
io.backend:io-backend ,
"default-buffer-size" "io.nonblocking" lookup ,
] { "alarms" "io" "tools" } strip-vocab-globals %
] { } make
{ "alarms" "io" "tools" } strip-vocab-globals %
strip-dictionary? [
{ } { "cpu" } strip-vocab-globals %
@ -193,7 +194,7 @@ IN: tools.deploy.shaker
global swap
'[ drop , member? not ] assoc-subset
[ drop string? not ] assoc-subset ! strip CLI args
dup keys .
dup keys unparse show
21 setenv
] [ drop ] if ;

8
extra/tools/vocabs/vocabs.factor
View File

@ -19,16 +19,16 @@ IN: tools.vocabs
] [ drop ] if ;
: vocab-tests ( vocab -- tests )
dup vocab-root [
dup vocab-root dup [
[
f >vocab-link dup
>vocab-link dup
vocab-tests-file,
vocab-tests-dir,
] { } make
] [ drop f ] if ;
] [ 2drop f ] if ;
: vocab-files ( vocab -- seq )
f >vocab-link [
dup find-vocab-root >vocab-link [
dup vocab-source-path [ , ] when*
dup vocab-docs-path [ , ] when*
vocab-tests %

20
extra/tools/walker/debug/debug.factor
View File

@ -2,17 +2,19 @@
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises models tools.walker kernel
sequences concurrency.messaging locals continuations
threads namespaces namespaces.private ;
threads namespaces namespaces.private assocs ;
IN: tools.walker.debug
:: test-walker ( quot -- data )
[let | p [ <promise> ]
s [ f <model> ]
c [ f <model> ] |
[let | p [ <promise> ] |
[
H{ } clone >n
[ s c start-walker-thread p fulfill ] new-walker-hook set
[ drop ] show-walker-hook set
[
p promise-fulfilled?
[ drop ] [ p fulfill ] if
2drop
] show-walker-hook set
break
@ -23,9 +25,7 @@ IN: tools.walker.debug
p ?promise
send-synchronous drop
detach
p ?promise
send-synchronous drop
c model-value continuation-data
thread-variables walker-continuation swap at
model-value continuation-data
] ;

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

@ -3,33 +3,51 @@
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models ;
sequences.private assocs models combinators.cleave ;
IN: tools.walker
SYMBOL: new-walker-hook ! ( -- )
SYMBOL: show-walker-hook ! ( thread -- )
SYMBOL: show-walker-hook ! ( status continuation thread -- )
! Thread local
! Thread local in thread being walked
SYMBOL: walker-thread
SYMBOL: walking-thread
: get-walker-thread ( -- thread )
! Thread local in walker thread
SYMBOL: walking-thread
SYMBOL: walker-status
SYMBOL: walker-continuation
SYMBOL: walker-history
DEFER: start-walker-thread
: get-walker-thread ( -- status continuation thread )
walker-thread tget [
dup show-walker-hook get call
[ thread-variables walker-status swap at ]
[ thread-variables walker-continuation swap at ]
[ ] tri
] [
new-walker-hook get call
walker-thread tget
f <model>
f <model>
2dup start-walker-thread
] if* ;
: break ( -- )
continuation callstack over set-continuation-call
USING: io.streams.c prettyprint ;
get-walker-thread send-synchronous {
: show-walker ( -- thread )
get-walker-thread
[ show-walker-hook get call ] keep ;
: after-break ( object -- )
{
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ "Single stepping abandoned" throw ] }
} cond ;
: break ( -- )
continuation callstack over set-continuation-call
show-walker send-synchronous
after-break ;
\ break t "break?" set-word-prop
: walk ( quot -- quot' )
@ -71,15 +89,9 @@ SYMBOL: detach
SYMBOL: abandon
SYMBOL: call-in
! Thread locals
SYMBOL: walker-status
SYMBOL: walker-continuation
SYMBOL: walker-history
SYMBOL: +running+
SYMBOL: +suspended+
SYMBOL: +stopped+
SYMBOL: +detached+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
@ -145,34 +157,20 @@ SYMBOL: +detached+
: set-status ( symbol -- )
walker-status tget set-model ;
: unassociate-thread ( -- )
walker-thread walking-thread tget thread-variables delete-at
[ ] walking-thread tget set-thread-exit-handler ;
: detach-msg ( -- )
+detached+ set-status
unassociate-thread ;
: keep-running ( -- )
+running+ set-status ;
: walker-stopped ( -- )
+stopped+ set-status
[ status +stopped+ eq? ] [
[
{
{ detach [ detach-msg ] }
[ drop ]
} case f
] handle-synchronous
] [ ] while ;
[ status +stopped+ eq? ]
[ [ drop f ] handle-synchronous ]
[ ] while ;
: step-into-all-loop ( -- )
+running+ set-status
[ status +running+ eq? ] [
[
{
{ detach [ detach-msg f ] }
{ step [ f ] }
{ step-out [ f ] }
{ step-into [ f ] }
@ -201,10 +199,6 @@ SYMBOL: +detached+
{
! These are sent by the walker tool. We reply
! and keep cycling.
{ detach [ detach-msg ] }
! These change the state of the thread being
! interpreted, so we modify the continuation and
! output f.
{ step [ step-msg keep-running ] }
{ step-out [ step-out-msg keep-running ] }
{ step-into [ step-into-msg keep-running ] }
@ -221,10 +215,9 @@ SYMBOL: +detached+
: walker-loop ( -- )
+running+ set-status
[ status +detached+ eq? not ] [
[ status +stopped+ eq? not ] [
[
{
{ detach [ detach-msg f ] }
! ignore these commands while the thread is
! running
{ step [ f ] }

5
extra/ui/freetype/freetype.factor
View File

@ -73,10 +73,7 @@ M: freetype-renderer free-fonts ( world -- )
] keep *void* ;
: open-face ( font style -- face )
ttf-name ttf-path
dup malloc-file-contents
swap file-info file-info-size
(open-face) ;
ttf-name ttf-path malloc-file-contents (open-face) ;
SYMBOL: dpi

41
extra/ui/tools/walker/walker.factor
View File

@ -4,14 +4,18 @@ USING: kernel concurrency.messaging inspector ui.tools.listener
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
ui.gadgets.tracks ui.commands ui.gadgets models
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
namespaces tools.walker assocs ;
namespaces tools.walker assocs combinators combinators.cleave ;
IN: ui.tools.walker
TUPLE: walker-gadget status continuation thread traceback ;
TUPLE: walker-gadget
status continuation thread
traceback
closing? ;
: walker-command ( walker msg -- )
over walker-gadget-thread thread-registered?
[ swap walker-gadget-thread send-synchronous drop ]
swap
dup walker-gadget-thread thread-registered?
[ walker-gadget-thread send-synchronous drop ]
[ 2drop ] if ;
: com-step ( walker -- ) step walker-command ;
@ -27,7 +31,9 @@ TUPLE: walker-gadget status continuation thread traceback ;
: com-abandon ( walker -- ) abandon walker-command ;
M: walker-gadget ungraft*
dup delegate ungraft* detach walker-command ;
[ t swap set-walker-gadget-closing? ]
[ com-continue ]
[ delegate ungraft* ] tri ;
M: walker-gadget focusable-child*
walker-gadget-traceback ;
@ -41,7 +47,6 @@ M: walker-gadget focusable-child*
{ +stopped+ "Stopped" }
{ +suspended+ "Suspended" }
{ +running+ "Running" }
{ +detached+ "Detached" }
} at %
")" %
drop
@ -51,7 +56,7 @@ M: walker-gadget focusable-child*
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
over <traceback-gadget> walker-gadget construct-boa [
over <traceback-gadget> f walker-gadget construct-boa [
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-traceback 1 track,
@ -72,16 +77,20 @@ walker-gadget "toolbar" f {
{ T{ key-down f f "F1" } walker-help }
} define-command-map
: walker-window ( -- )
f <model> f <model> 2dup start-walker-thread
[ <walker-gadget> ] keep thread-name open-status-window ;
: walker-for-thread? ( thread gadget -- ? )
{
{ [ dup walker-gadget? not ] [ 2drop f ] }
{ [ dup walker-gadget-closing? ] [ 2drop f ] }
{ [ t ] [ walker-gadget-thread eq? ] }
} cond ;
[ [ walker-window ] with-ui ] new-walker-hook set-global
: find-walker-window ( thread -- world/f )
[ swap walker-for-thread? ] curry find-window ;
: walker-window ( status continuation thread -- )
[ <walker-gadget> ] [ thread-name ] bi open-status-window ;
[
[
>r dup walker-gadget?
[ walker-gadget-thread r> eq? ]
[ r> 2drop f ] if
] curry find-window raise-window
dup find-walker-window dup
[ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
] show-walker-hook set-global

27
extra/ui/windows/windows.factor
View File

@ -376,6 +376,22 @@ SYMBOL: trace-messages?
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
! ! ! !
: set-world-dim ( dim world -- )
swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0
SetWindowPos drop ;
USE: random
USE: arrays
: twiddle
100 500 random +
100 500 random +
2array
"x" get-global find-world
set-world-dim
yield ;
! ! ! !
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
@ -436,17 +452,16 @@ SYMBOL: trace-messages?
: init-win32-ui ( -- )
V{ } clone nc-buttons set-global
"MSG" <c-object> msg-obj set-global
"MSG" malloc-object msg-obj set-global
"Factor-window" malloc-u16-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
class-name-ptr get-global [
dup f UnregisterClass drop
free
] when*
f class-name-ptr set-global ;
class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
msg-obj get-global [ free ] when*
f class-name-ptr set-global
f msg-obj set-global ;
: setup-pixel-format ( hdc -- )
16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep

2
extra/unicode/data/data.factor
View File

@ -5,7 +5,7 @@ IN: unicode.data
<<
: VALUE:
CREATE dup reset-generic { f } clone [ first ] curry define ; parsing
CREATE-WORD { f } clone [ first ] curry define ; parsing
: set-value ( value word -- )
word-def first set-first ;

8
extra/windows/user32/user32.factor
View File

@ -1283,7 +1283,13 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
! FUNCTION: SetWindowLongA
! FUNCTION: SetWindowLongW
! FUNCTION: SetWindowPlacement
! FUNCTION: SetWindowPos
FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
: HWND_BOTTOM ALIEN: 1 ;
: HWND_NOTOPMOST ALIEN: -2 ;
: HWND_TOP ALIEN: 0 ;
: HWND_TOPMOST ALIEN: -1 ;
! FUNCTION: SetWindowRgn
! FUNCTION: SetWindowsHookA
! FUNCTION: SetWindowsHookExA

8
misc/factor.el
View File

@ -158,6 +158,11 @@
(insert str)
(comint-send-input))))
(defun factor-send-definition ()
(interactive)
(factor-send-region (search-backward ":")
(search-forward ";")))
(defun factor-see ()
(interactive)
(comint-send-string "*factor*" "\\ ")
@ -187,6 +192,7 @@
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
(define-key factor-mode-map "\C-c\C-s" 'factor-see)
(define-key factor-mode-map "\C-ce" 'factor-edit)
(define-key factor-mode-map "\C-c\C-h" 'factor-help)
@ -212,3 +218,5 @@
(defun factor-refresh-all ()
(interactive)
(comint-send-string "*factor*" "refresh-all\n"))

6
vm/alien.c
View File

@ -197,15 +197,15 @@ DEFINE_PRIMITIVE(dlsym)
F_DLL *d;
if(dll == F)
d = NULL;
box_alien(ffi_dlsym(NULL,sym));
else
{
d = untag_dll(dll);
if(d->dll == NULL)
dpush(F);
else
box_alien(ffi_dlsym(d,sym));
}
box_alien(ffi_dlsym(d,sym));
}
/* close a native library handle */

2
vm/code_gc.c
View File

@ -375,6 +375,8 @@ void forward_object_xts(void)
F_WORD *word = untag_object(obj);
word->code = forward_xt(word->code);
if(word->profiling)
word->profiling = forward_xt(word->profiling);
}
else if(type_of(obj) == QUOTATION_TYPE)
{

9
vm/data_gc.h
View File

@ -263,13 +263,18 @@ DEFPUSHPOP(root_,extra_roots)
#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
INLINE bool in_data_heap_p(CELL ptr)
{
return (ptr >= data_heap->segment->start
&& ptr <= data_heap->segment->end);
}
/* We ignore strings which point outside the data heap, but we might be given
a char* which points inside the data heap, in which case it is a root, for
example if we call unbox_char_string() the result is placed in a byte array */
INLINE bool root_push_alien(const void *ptr)
{
if((CELL)ptr > data_heap->segment->start
&& (CELL)ptr < data_heap->segment->end)
if(in_data_heap_p((CELL)ptr))
{
F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
if(objptr->header == tag_header(BYTE_ARRAY_TYPE))