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

Fixing conflicts from stack checker changes

db4
Slava Pestov 2009-02-24 01:21:10 -06:00
parent 91d0c4ed1f e8361b9980
commit ce1bc1d6ed
111 changed files with 1040 additions and 1330 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/alien/c-types/c-types.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting namespaces make parser sequences strings words assocs splitting
@ -275,7 +275,7 @@ M: long-long-type box-return ( type -- )
: if-void ( type true false -- ) : if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline pick "void" = [ drop nip call ] [ nip call ] if ; inline
: primitive-types CONSTANT: primitive-types
{ {
"char" "uchar" "char" "uchar"
"short" "ushort" "short" "ushort"
@ -284,7 +284,7 @@ M: long-long-type box-return ( type -- )
"longlong" "ulonglong" "longlong" "ulonglong"
"float" "double" "float" "double"
"void*" "bool" "void*" "bool"
} ; }
[ [
<c-type> <c-type>

2
basis/bootstrap/image/download/download.factor
View File

@ -4,7 +4,7 @@ USING: http.client checksums checksums.md5 splitting assocs
kernel io.files bootstrap.image sequences io urls ; kernel io.files bootstrap.image sequences io urls ;
IN: bootstrap.image.download IN: bootstrap.image.download
: url URL" http://factorcode.org/images/latest/" ; CONSTANT: url URL" http://factorcode.org/images/latest/"
: download-checksums ( -- alist ) : download-checksums ( -- alist )
url "checksums.txt" >url derive-url http-get nip url "checksums.txt" >url derive-url http-get nip

6
basis/cairo/ffi/ffi.factor
View File

@ -72,9 +72,9 @@ C-ENUM:
CAIRO_STATUS_INVALID_STRIDE ; CAIRO_STATUS_INVALID_STRIDE ;
TYPEDEF: int cairo_content_t TYPEDEF: int cairo_content_t
: CAIRO_CONTENT_COLOR HEX: 1000 ; CONSTANT: CAIRO_CONTENT_COLOR HEX: 1000
: CAIRO_CONTENT_ALPHA HEX: 2000 ; CONSTANT: CAIRO_CONTENT_ALPHA HEX: 2000
: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ; CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
TYPEDEF: void* cairo_write_func_t TYPEDEF: void* cairo_write_func_t
: cairo-write-func ( quot -- callback ) : cairo-write-func ( quot -- callback )

4
basis/checksums/openssl/openssl.factor
View File

@ -9,9 +9,9 @@ ERROR: unknown-digest name ;
TUPLE: openssl-checksum name ; TUPLE: openssl-checksum name ;
: openssl-md5 T{ openssl-checksum f "md5" } ; CONSTANT: openssl-md5 T{ openssl-checksum f "md5" }
: openssl-sha1 T{ openssl-checksum f "sha1" } ; CONSTANT: openssl-sha1 T{ openssl-checksum f "sha1" }
INSTANCE: openssl-checksum stream-checksum INSTANCE: openssl-checksum stream-checksum

4
basis/cocoa/dialogs/dialogs.factor
View File

@ -18,8 +18,8 @@ IN: cocoa.dialogs
dup 0 -> setCanChooseDirectories: dup 0 -> setCanChooseDirectories:
dup 0 -> setAllowsMultipleSelection: ; dup 0 -> setAllowsMultipleSelection: ;
: NSOKButton 1 ; CONSTANT: NSOKButton 1
: NSCancelButton 0 ; CONSTANT: NSCancelButton 0
: open-panel ( -- paths ) : open-panel ( -- paths )
<NSOpenPanel> <NSOpenPanel>

12
basis/cocoa/messages/messages.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs USING: accessors alien alien.c-types alien.strings arrays assocs
continuations combinators compiler compiler.alien kernel math continuations combinators compiler compiler.alien stack-checker kernel
namespaces make parser quotations sequences strings words math namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8 cocoa.runtime io macros memoize io.encodings.utf8 effects libc
effects libc libc.private parser lexer init core-foundation fry libc.private parser lexer init core-foundation fry generalizations
generalizations specialized-arrays.direct.alien call ; specialized-arrays.direct.alien call ;
IN: cocoa.messages IN: cocoa.messages
: make-sender ( method function -- quot ) : make-sender ( method function -- quot )
@ -14,7 +14,7 @@ IN: cocoa.messages
: sender-stub ( method function -- word ) : sender-stub ( method function -- word )
[ "( sender-stub )" f <word> dup ] 2dip [ "( sender-stub )" f <word> dup ] 2dip
over first large-struct? [ "_stret" append ] when over first large-struct? [ "_stret" append ] when
make-sender define ; make-sender dup infer define-declared ;
SYMBOL: message-senders SYMBOL: message-senders
SYMBOL: super-message-senders SYMBOL: super-message-senders

2
basis/cocoa/pasteboard/pasteboard.factor
View File

@ -5,7 +5,7 @@ cocoa.classes cocoa.application sequences cocoa core-foundation
core-foundation.strings core-foundation.arrays ; core-foundation.strings core-foundation.arrays ;
IN: cocoa.pasteboard IN: cocoa.pasteboard
: NSStringPboardType "NSStringPboardType" ; CONSTANT: NSStringPboardType "NSStringPboardType"
: pasteboard-string? ( pasteboard -- ? ) : pasteboard-string? ( pasteboard -- ? )
NSStringPboardType swap -> types CF>string-array member? ; NSStringPboardType swap -> types CF>string-array member? ;

18
basis/cocoa/runtime/runtime.factor
View File

@ -21,15 +21,15 @@ C-STRUCT: objc-super
{ "id" "receiver" } { "id" "receiver" }
{ "Class" "class" } ; { "Class" "class" } ;
: CLS_CLASS HEX: 1 ; CONSTANT: CLS_CLASS HEX: 1
: CLS_META HEX: 2 ; CONSTANT: CLS_META HEX: 2
: CLS_INITIALIZED HEX: 4 ; CONSTANT: CLS_INITIALIZED HEX: 4
: CLS_POSING HEX: 8 ; CONSTANT: CLS_POSING HEX: 8
: CLS_MAPPED HEX: 10 ; CONSTANT: CLS_MAPPED HEX: 10
: CLS_FLUSH_CACHE HEX: 20 ; CONSTANT: CLS_FLUSH_CACHE HEX: 20
: CLS_GROW_CACHE HEX: 40 ; CONSTANT: CLS_GROW_CACHE HEX: 40
: CLS_NEED_BIND HEX: 80 ; CONSTANT: CLS_NEED_BIND HEX: 80
: CLS_METHOD_ARRAY HEX: 100 ; CONSTANT: CLS_METHOD_ARRAY HEX: 100
FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ; FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;

6
basis/cocoa/subclassing/subclassing.factor
View File

@ -39,9 +39,9 @@ IN: cocoa.subclassing
swap prefix [ encode-type "0" append ] map concat ; swap prefix [ encode-type "0" append ] map concat ;
: prepare-method ( ret types quot -- type imp ) : prepare-method ( ret types quot -- type imp )
[ [ encode-types ] 2keep ] dip [ [ [ encode-types ] 2keep ] dip
"cdecl" swap 4array % \ alien-callback , '[ _ _ "cdecl" _ alien-callback ]
] [ ] make define-temp ; (( -- callback )) define-temp ;
: prepare-methods ( methods -- methods ) : prepare-methods ( methods -- methods )
[ [

4
basis/cocoa/views/views.factor
View File

@ -40,10 +40,6 @@ CONSTANT: NSOpenGLPFAScreenMask 84
CONSTANT: NSOpenGLPFAPixelBuffer 90 CONSTANT: NSOpenGLPFAPixelBuffer 90
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96 CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
CONSTANT: NSOpenGLPFAVirtualScreenCount 128 CONSTANT: NSOpenGLPFAVirtualScreenCount 128
CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
CONSTANT: NSOpenGLCPSwapInterval 222 CONSTANT: NSOpenGLCPSwapInterval 222
<PRIVATE <PRIVATE

2
basis/compiler/cfg/debugger/debugger.factor
View File

@ -16,7 +16,7 @@ M: callable test-cfg
build-tree optimize-tree gensym build-cfg ; build-tree optimize-tree gensym build-cfg ;
M: word test-cfg M: word test-cfg
[ build-tree-from-word nip optimize-tree ] keep build-cfg ; [ build-tree-from-word optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers? SYMBOL: allocate-registers?

9
basis/compiler/compiler-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax words io parser USING: help.markup help.syntax words io parser
assocs words.private sequences compiler.units ; assocs words.private sequences compiler.units quotations ;
IN: compiler IN: compiler
HELP: enable-compiler HELP: enable-compiler
@ -16,6 +16,8 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
{ $subsection optimized-recompile-hook } { $subsection optimized-recompile-hook }
"Removing a word's optimized definition:" "Removing a word's optimized definition:"
{ $subsection decompile } { $subsection decompile }
"Compiling a single quotation:"
{ $subsection compile-call }
"Higher-level words can be found in " { $link "compilation-units" } "." ; "Higher-level words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler" ARTICLE: "compiler" "Optimizing compiler"
@ -48,3 +50,8 @@ HELP: optimized-recompile-hook
{ $values { "words" "a sequence of words" } { "alist" "an association list" } } { $values { "words" "a sequence of words" } { "alist" "an association list" } }
{ $description "Compile a set of words." } { $description "Compile a set of words." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
HELP: compile-call
{ $values { "quot" quotation } }
{ $description "Compiles and runs a quotation." }
{ $notes "This word is used by compiler unit tests to test compilation of small pieces of code." } ;

62
basis/compiler/compiler.factor
View File

@ -1,46 +1,47 @@
! Copyright (C) 2004, 2009 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io USING: accessors kernel namespaces arrays sequences io words fry
words fry continuations vocabs assocs dlists definitions math continuations vocabs assocs dlists definitions math graphs
graphs generic combinators deques search-deques io generic combinators deques search-deques io stack-checker
stack-checker stack-checker.state stack-checker.inlining stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder combinators.short-circuit compiler.errors compiler.units
compiler.tree.optimizer compiler.cfg.builder compiler.tree.builder compiler.tree.optimizer
compiler.cfg.optimizer compiler.cfg.linearization compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.two-operand compiler.cfg.linear-scan compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.stack-frame compiler.codegen compiler.utilities ; compiler.cfg.linear-scan compiler.cfg.stack-frame
compiler.codegen compiler.utilities ;
IN: compiler IN: compiler
SYMBOL: compile-queue SYMBOL: compile-queue
SYMBOL: compiled SYMBOL: compiled
: queue-compile ( word -- ) : queue-compile? ( word -- ? )
{ {
{ [ dup "forgotten" word-prop ] [ ] } [ "forgotten" word-prop ]
{ [ dup compiled get key? ] [ ] } [ compiled get key? ]
{ [ dup inlined-block? ] [ ] } [ inlined-block? ]
{ [ dup primitive? ] [ ] } [ primitive? ]
[ dup compile-queue get push-front ] } 1|| not ;
} cond drop ;
: queue-compile ( word -- )
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
: maybe-compile ( word -- ) : maybe-compile ( word -- )
dup optimized>> [ drop ] [ queue-compile ] if ; dup optimized>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+ SYMBOLS: +optimized+ +unoptimized+ ;
: ripple-up ( words -- ) : ripple-up ( words -- )
dup "compiled-effect" word-prop +failed+ eq? dup "compiled-status" word-prop +unoptimized+ eq?
[ usage [ word? ] filter ] [ compiled-usage keys ] if [ usage [ word? ] filter ] [ compiled-usage keys ] if
[ queue-compile ] each ; [ queue-compile ] each ;
: ripple-up? ( word effect -- ? ) : ripple-up? ( word status -- ? )
#! If the word has previously been compiled and had a swap "compiled-status" word-prop [ = not ] keep and ;
#! different stack effect, we have to recompile any callers.
swap "compiled-effect" word-prop [ = not ] keep and ;
: save-effect ( word effect -- ) : save-compiled-status ( word status -- )
[ dupd ripple-up? [ ripple-up ] [ drop ] if ] [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
[ "compiled-effect" set-word-prop ] [ "compiled-status" set-word-prop ]
2bi ; 2bi ;
: start ( word -- ) : start ( word -- )
@ -49,18 +50,18 @@ SYMBOL: +failed+
H{ } clone generic-dependencies set H{ } clone generic-dependencies set
f swap compiler-error ; f swap compiler-error ;
: fail ( word error -- ) : fail ( word error -- * )
[ swap compiler-error ] [ swap compiler-error ]
[ [
drop drop
[ compiled-unxref ] [ compiled-unxref ]
[ f swap compiled get set-at ] [ f swap compiled get set-at ]
[ +failed+ save-effect ] [ +unoptimized+ save-compiled-status ]
tri tri
] 2bi ] 2bi
return ; return ;
: frontend ( word -- effect nodes ) : frontend ( word -- nodes )
[ build-tree-from-word ] [ fail ] recover optimize-tree ; [ build-tree-from-word ] [ fail ] recover optimize-tree ;
! Only switch this off for debugging. ! Only switch this off for debugging.
@ -84,8 +85,8 @@ t compile-dependencies? set-global
save-asm save-asm
] each ; ] each ;
: finish ( effect word -- ) : finish ( word -- )
[ swap save-effect ] [ +optimized+ save-compiled-status ]
[ compiled-unxref ] [ compiled-unxref ]
[ [
dup crossref? dup crossref?
@ -112,6 +113,9 @@ t compile-dependencies? set-global
: decompile ( word -- ) : decompile ( word -- )
f 2array 1array modify-code-heap ; f 2array 1array modify-code-heap ;
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
: optimized-recompile-hook ( words -- alist ) : optimized-recompile-hook ( words -- alist )
[ [
<hashed-dlist> compile-queue set <hashed-dlist> compile-queue set

4
basis/compiler/tests/codegen.factor
View File

@ -51,7 +51,7 @@ unit-test
\ foo [ global >n get ndrop ] compile-call \ foo [ global >n get ndrop ] compile-call
] unit-test ] unit-test
: blech drop ; : blech ( x -- ) drop ;
[ 3 ] [ 3 ]
[ [
@ -102,7 +102,7 @@ unit-test
[ ] [ [ ] [
[ [
[ 200 dup [ 200 3array ] curry map drop ] times [ 200 dup [ 200 3array ] curry map drop ] times
] [ define-temp ] with-compilation-unit drop ] [ (( n -- )) define-temp ] with-compilation-unit drop
] unit-test ] unit-test
! Test how dispatch handles the end of a basic block ! Test how dispatch handles the end of a basic block

8
basis/compiler/tests/curry.factor
View File

@ -1,5 +1,5 @@
USING: tools.test quotations math kernel sequences USING: tools.test quotations math kernel sequences
assocs namespaces make compiler.units ; assocs namespaces make compiler.units compiler ;
IN: compiler.tests IN: compiler.tests
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
@ -32,15 +32,15 @@ IN: compiler.tests
compile-call compile-call
] unit-test ] unit-test
: foobar ( quot -- ) : foobar ( quot: ( -- ) -- )
dup slip swap [ foobar ] [ drop ] if ; inline dup slip swap [ foobar ] [ drop ] if ; inline recursive
[ ] [ [ [ f ] foobar ] compile-call ] unit-test [ ] [ [ [ f ] foobar ] compile-call ] unit-test
[ { 6 7 8 } ] [ { 1 2 3 } 5 [ [ + ] curry map ] compile-call ] unit-test [ { 6 7 8 } ] [ { 1 2 3 } 5 [ [ + ] curry map ] compile-call ] unit-test
[ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-call ] unit-test [ { 6 7 8 } ] [ { 1 2 3 } [ 5 [ + ] curry map ] compile-call ] unit-test
: funky-assoc>map : funky-assoc>map ( assoc quot -- seq )
[ [
[ call f ] curry assoc-find 3drop [ call f ] curry assoc-find 3drop
] { } make ; inline ] { } make ; inline

2
basis/compiler/tests/float.factor
View File

@ -1,5 +1,5 @@
IN: compiler.tests IN: compiler.tests
USING: compiler.units kernel kernel.private memory math USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test

2
basis/compiler/tests/intrinsics.factor
View File

@ -5,7 +5,7 @@ strings.private system random layouts vectors
sbufs strings.private slots.private alien math.order sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii namespaces libc sequences.private io.encodings.ascii
classes ; classes compiler ;
IN: compiler.tests IN: compiler.tests
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.

33
basis/compiler/tests/optimizer.factor
View File

@ -3,7 +3,8 @@ stack-checker kernel kernel.private math prettyprint sequences
sbufs strings tools.test vectors words sequences.private sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep ; compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler ;
IN: optimizer.tests IN: optimizer.tests
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
@ -54,7 +55,7 @@ TUPLE: pred-test ;
! regression ! regression
: literal-not-branch 0 not [ ] [ ] if ; : literal-not-branch ( -- ) 0 not [ ] [ ] if ;
[ ] [ literal-not-branch ] unit-test [ ] [ literal-not-branch ] unit-test
@ -107,12 +108,12 @@ GENERIC: void-generic ( obj -- * )
[ 10 ] [ branch-fold-regression-1 ] unit-test [ 10 ] [ branch-fold-regression-1 ] unit-test
! another regression ! another regression
: constant-branch-fold-0 "hey" ; foldable : constant-branch-fold-0 ( -- value ) "hey" ; foldable
: constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline : constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test [ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression ! another regression
: foo f ; : foo ( -- value ) f ;
: bar ( -- ? ) foo 4 4 = and ; : bar ( -- ? ) foo 4 4 = and ;
[ f ] [ bar ] unit-test [ f ] [ bar ] unit-test
@ -133,15 +134,15 @@ M: slice foozul ;
] unit-test ] unit-test
! regression ! regression
: constant-fold-2 f ; foldable : constant-fold-2 ( -- value ) f ; foldable
: constant-fold-3 4 ; foldable : constant-fold-3 ( -- value ) 4 ; foldable
[ f t ] [ [ f t ] [
[ constant-fold-2 constant-fold-3 4 = ] compile-call [ constant-fold-2 constant-fold-3 4 = ] compile-call
] unit-test ] unit-test
: constant-fold-4 f ; foldable : constant-fold-4 ( -- value ) f ; foldable
: constant-fold-5 f ; foldable : constant-fold-5 ( -- value ) f ; foldable
[ f ] [ [ f ] [
[ constant-fold-4 constant-fold-5 or ] compile-call [ constant-fold-4 constant-fold-5 or ] compile-call
@ -208,14 +209,14 @@ USE: sorting
USE: binary-search USE: binary-search
USE: binary-search.private USE: binary-search.private
: old-binsearch ( elt quot seq -- elt quot i ) : old-binsearch ( elt quot: ( -- ) seq -- elt quot i )
dup length 1 <= [ dup length 1 <= [
from>> from>>
] [ ] [
[ midpoint swap call ] 3keep roll dup zero? [ midpoint swap call ] 3keep roll dup zero?
[ drop dup from>> swap midpoint@ + ] [ drop dup from>> swap midpoint@ + ]
[ dup midpoint@ cut-slice old-binsearch ] if [ drop dup midpoint@ head-slice old-binsearch ] if
] if ; inline ] if ; inline recursive
[ 10 ] [ [ 10 ] [
10 20 >vector <flat-slice> 10 20 >vector <flat-slice>
@ -246,7 +247,7 @@ USE: binary-search.private
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
: lift-loop-tail-test-1 ( a quot -- ) : lift-loop-tail-test-1 ( a quot: ( -- ) -- )
over even? [ over even? [
[ [ 3 - ] dip call ] keep lift-loop-tail-test-1 [ [ 3 - ] dip call ] keep lift-loop-tail-test-1
] [ ] [
@ -255,11 +256,13 @@ USE: binary-search.private
] [ ] [
[ [ 2 - ] dip call ] keep lift-loop-tail-test-1 [ [ 2 - ] dip call ] keep lift-loop-tail-test-1
] if ] if
] if ; inline ] if ; inline recursive
: lift-loop-tail-test-2 : lift-loop-tail-test-2 ( -- a b c )
10 [ ] lift-loop-tail-test-1 1 2 3 ; 10 [ ] lift-loop-tail-test-1 1 2 3 ;
\ lift-loop-tail-test-2 must-infer
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
! Forgot a recursive inline check ! Forgot a recursive inline check
@ -300,7 +303,7 @@ HINTS: recursive-inline-hang-3 array ;
: member-test ( obj -- ? ) { + - * / /i } member? ; : member-test ( obj -- ? ) { + - * / /i } member? ;
\ member-test must-infer \ member-test must-infer
[ ] [ \ member-test build-tree-from-word optimize-tree 2drop ] unit-test [ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test
[ t ] [ \ + member-test ] unit-test [ t ] [ \ + member-test ] unit-test
[ f ] [ \ append member-test ] unit-test [ f ] [ \ append member-test ] unit-test

15
basis/compiler/tests/peg-regression-2.factor Normal file
View File

@ -0,0 +1,15 @@
IN: compiler.tests
USING: peg.ebnf strings tools.test ;
GENERIC: <times> ( times -- term' )
M: string <times> ;
EBNF: parse-regexp
Times = .* => [[ "foo" ]]
Regexp = Times:t => [[ t <times> ]]
;EBNF
[ "foo" ] [ "a" parse-regexp ] unit-test

6
basis/compiler/tests/simple.factor
View File

@ -18,13 +18,13 @@ IN: compiler.tests
[ "hey" ] [ [ "hey" ] compile-call ] unit-test [ "hey" ] [ [ "hey" ] compile-call ] unit-test
! Calls ! Calls
: no-op ; : no-op ( -- ) ;
[ ] [ [ no-op ] compile-call ] unit-test [ ] [ [ no-op ] compile-call ] unit-test
[ 3 ] [ [ no-op 3 ] compile-call ] unit-test [ 3 ] [ [ no-op 3 ] compile-call ] unit-test
[ 3 ] [ [ 3 no-op ] compile-call ] unit-test [ 3 ] [ [ 3 no-op ] compile-call ] unit-test
: bar 4 ; : bar ( -- value ) 4 ;
[ 4 ] [ [ bar no-op ] compile-call ] unit-test [ 4 ] [ [ bar no-op ] compile-call ] unit-test
[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test [ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
@ -54,7 +54,7 @@ IN: compiler.tests
! Labels ! Labels
: recursive-test ( ? -- ) [ f recursive-test ] when ; inline : recursive-test ( ? -- ) [ f recursive-test ] when ; inline recursive
[ ] [ t [ recursive-test ] compile-call ] unit-test [ ] [ t [ recursive-test ] compile-call ] unit-test

2
basis/compiler/tests/tuples.factor
View File

@ -1,5 +1,5 @@
IN: compiler.tests IN: compiler.tests
USING: kernel tools.test compiler.units ; USING: kernel tools.test compiler.units compiler ;
TUPLE: color red green blue ; TUPLE: color red green blue ;

2
basis/compiler/tree/builder/builder-tests.factor
View File

@ -8,4 +8,4 @@ compiler.tree ;
: inline-recursive ( -- ) inline-recursive ; inline recursive : inline-recursive ( -- ) inline-recursive ; inline recursive
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? nip ] unit-test [ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test

8
basis/compiler/tree/builder/builder.factor
View File

@ -12,18 +12,18 @@ IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes ) : with-tree-builder ( quot -- nodes )
'[ V{ } clone stack-visitor set @ ] '[ V{ } clone stack-visitor set @ ]
with-infer ; inline with-infer nip ; inline
: build-tree ( quot -- nodes ) : build-tree ( quot -- nodes )
#! Not safe to call from inference transforms. #! Not safe to call from inference transforms.
[ f initial-recursive-state infer-quot ] with-tree-builder nip ; [ f initial-recursive-state infer-quot ] with-tree-builder ;
: build-tree-with ( in-stack quot -- nodes out-stack ) : build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms. #! Not safe to call from inference transforms.
[ [
[ >vector \ meta-d set ] [ >vector \ meta-d set ]
[ f initial-recursive-state infer-quot ] bi* [ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip ] with-tree-builder
unclip-last in-d>> ; unclip-last in-d>> ;
: build-sub-tree ( #call quot -- nodes ) : build-sub-tree ( #call quot -- nodes )
@ -45,7 +45,7 @@ IN: compiler.tree.builder
: check-no-compile ( word -- ) : check-no-compile ( word -- )
dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ; dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
: build-tree-from-word ( word -- effect nodes ) : build-tree-from-word ( word -- nodes )
[ [
[ [
{ {

2
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -474,7 +474,7 @@ cell-bits 32 = [
] unit-test ] unit-test
! A reduction ! A reduction
: buffalo-sauce f ; : buffalo-sauce ( -- value ) f ;
: steak ( -- ) : steak ( -- )
buffalo-sauce [ steak ] when ; inline recursive buffalo-sauce [ steak ] when ; inline recursive

4
basis/compiler/tree/comparisons/comparisons.factor
View File

@ -5,9 +5,9 @@ IN: compiler.tree.comparisons
! Some utilities for working with comparison operations. ! Some utilities for working with comparison operations.
: comparison-ops { < > <= >= } ; CONSTANT: comparison-ops { < > <= >= }
: generic-comparison-ops { before? after? before=? after=? } ; CONSTANT: generic-comparison-ops { before? after? before=? after=? }
: assumption ( i1 i2 op -- i3 ) : assumption ( i1 i2 op -- i3 )
{ {

2
basis/compiler/tree/debugger/debugger.factor
View File

@ -144,7 +144,7 @@ SYMBOL: node-count
: make-report ( word/quot -- assoc ) : make-report ( word/quot -- assoc )
[ [
dup word? [ build-tree-from-word nip ] [ build-tree ] if dup word? [ build-tree-from-word ] [ build-tree ] if
optimize-tree optimize-tree
H{ } clone words-called set H{ } clone words-called set

2
basis/compiler/tree/recursive/recursive-tests.factor
View File

@ -87,7 +87,7 @@ compiler.tree.combinators ;
] contains-node? ] contains-node?
] unit-test ] unit-test
: blah f ; : blah ( -- value ) f ;
DEFER: a DEFER: a

6
basis/core-graphics/core-graphics.factor
View File

@ -99,10 +99,12 @@ FUNCTION: void CGContextSetShouldSmoothFonts (
bool shouldSmoothFonts bool shouldSmoothFonts
) ; ) ;
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ; FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
<PRIVATE <PRIVATE
: bitmap-flags ( -- flags ) : bitmap-flags ( -- flags )

4
basis/db/errors/postgresql/postgresql-tests.factor
View File

@ -5,7 +5,7 @@ db.errors.postgresql db.postgresql io.files.unique kernel namespaces
tools.test db.tester continuations ; tools.test db.tester continuations ;
IN: db.errors.postgresql.tests IN: db.errors.postgresql.tests
postgresql-test-db [ [
[ "drop table foo;" sql-command ] ignore-errors [ "drop table foo;" sql-command ] ignore-errors
[ "drop table ship;" sql-command ] ignore-errors [ "drop table ship;" sql-command ] ignore-errors
@ -29,4 +29,4 @@ postgresql-test-db [
sql-syntax-error? sql-syntax-error?
] must-fail-with ] must-fail-with
] with-db ] test-postgresql

4
basis/editors/emacs/emacs.factor
View File

@ -1,6 +1,6 @@
USING: definitions io.launcher kernel parser words sequences math USING: definitions io.launcher kernel parser words sequences math
math.parser namespaces editors make system combinators.short-circuit math.parser namespaces editors make system combinators.short-circuit
fry threads ; fry threads vocabs.loader ;
IN: editors.emacs IN: editors.emacs
SYMBOL: emacsclient-path SYMBOL: emacsclient-path
@ -22,3 +22,5 @@ M: object default-emacsclient ( -- path ) "emacsclient" ;
where first2 emacsclient ; where first2 emacsclient ;
[ emacsclient ] edit-hook set-global [ emacsclient ] edit-hook set-global
os windows? [ "editors.emacs.windows" require ] when

2
basis/farkup/farkup.factor
View File

@ -157,7 +157,7 @@ stand-alone
= (line | code | heading | list | table | paragraph | nl)* = (line | code | heading | list | table | paragraph | nl)*
;EBNF ;EBNF
: invalid-url "javascript:alert('Invalid URL in farkup');" ; CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');"
: check-url ( href -- href' ) : check-url ( href -- href' )
{ {

4
basis/functors/functors.factor
View File

@ -80,9 +80,9 @@ M: object fake-quotations> ;
scan-param parsed scan-param parsed
\ add-mixin-instance parsed ; parsing \ add-mixin-instance parsed ; parsing
: `inline \ inline parsed ; parsing : `inline [ word make-inline ] over push-all ; parsing
: `parsing \ parsing parsed ; parsing : `parsing [ word make-parsing ] over push-all ; parsing
: `( : `(
")" parse-effect effect set ; parsing ")" parse-effect effect set ; parsing

2
basis/furnace/actions/actions.factor
View File

@ -63,7 +63,7 @@ TUPLE: action rest init authorize display validate submit ;
: param ( name -- value ) : param ( name -- value )
params get at ; params get at ;
: revalidate-url-key "__u" ; CONSTANT: revalidate-url-key "__u"
: revalidate-url ( -- url/f ) : revalidate-url ( -- url/f )
revalidate-url-key param revalidate-url-key param

2
basis/furnace/alloy/alloy.factor
View File

@ -10,7 +10,7 @@ furnace.auth.providers
furnace.auth.login.permits ; furnace.auth.login.permits ;
IN: furnace.alloy IN: furnace.alloy
: state-classes { session aside conversation permit } ; inline CONSTANT: state-classes { session aside conversation permit }
: init-furnace-tables ( -- ) : init-furnace-tables ( -- )
state-classes ensure-tables state-classes ensure-tables

2
basis/furnace/asides/asides.factor
View File

@ -23,7 +23,7 @@ aside "ASIDES" {
{ "post-data" "POST_DATA" FACTOR-BLOB } { "post-data" "POST_DATA" FACTOR-BLOB }
} define-persistent } define-persistent
: aside-id-key "__a" ; CONSTANT: aside-id-key "__a"
TUPLE: asides < server-state-manager ; TUPLE: asides < server-state-manager ;

2
basis/furnace/auth/login/login.factor
View File

@ -64,7 +64,7 @@ SYMBOL: capabilities
PRIVATE> PRIVATE>
: flashed-variables { description capabilities } ; CONSTANT: flashed-variables { description capabilities }
: login-failed ( -- * ) : login-failed ( -- * )
"invalid username or password" validation-error "invalid username or password" validation-error

4
basis/furnace/auth/providers/null/null.factor
View File

@ -3,9 +3,7 @@
USING: furnace.auth.providers kernel ; USING: furnace.auth.providers kernel ;
IN: furnace.auth.providers.null IN: furnace.auth.providers.null
TUPLE: no-users ; SINGLETON: no-users
: no-users T{ no-users } ;
M: no-users get-user 2drop f ; M: no-users get-user 2drop f ;

2
basis/furnace/conversations/conversations.factor
View File

@ -20,7 +20,7 @@ conversation "CONVERSATIONS" {
{ "session" "SESSION" BIG-INTEGER +not-null+ } { "session" "SESSION" BIG-INTEGER +not-null+ }
} define-persistent } define-persistent
: conversation-id-key "__c" ; CONSTANT: conversation-id-key "__c"
TUPLE: conversations < server-state-manager ; TUPLE: conversations < server-state-manager ;

2
basis/furnace/sessions/sessions.factor
View File

@ -73,7 +73,7 @@ TUPLE: sessions < server-state-manager domain verify? ;
[ session set ] [ save-session-after ] bi [ session set ] [ save-session-after ] bi
sessions get responder>> call-responder ; sessions get responder>> call-responder ;
: session-id-key "__s" ; CONSTANT: session-id-key "__s"
: verify-session ( session -- session ) : verify-session ( session -- session )
sessions get verify?>> [ sessions get verify?>> [

4
basis/furnace/utilities/utilities.factor
View File

@ -89,7 +89,7 @@ M: object modify-form drop f ;
[XML <input type="hidden" value=<-> name=<->/> XML] [XML <input type="hidden" value=<-> name=<->/> XML]
] [ drop ] if ; ] [ drop ] if ;
: nested-forms-key "__n" ; CONSTANT: nested-forms-key "__n"
: request-params ( request -- assoc ) : request-params ( request -- assoc )
dup method>> { dup method>> {
@ -131,7 +131,7 @@ M: object modify-form drop f ;
SYMBOL: exit-continuation SYMBOL: exit-continuation
: exit-with ( value -- ) : exit-with ( value -- * )
exit-continuation get continue-with ; exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value ) : with-exit-continuation ( quot -- value )

2
basis/html/templates/chloe/syntax/syntax.factor
View File

@ -18,7 +18,7 @@ tags [ H{ } clone ] initialize
: CHLOE: : CHLOE:
scan parse-definition define-chloe-tag ; parsing scan parse-definition define-chloe-tag ; parsing
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline CONSTANT: chloe-ns "http://factorcode.org/chloe/1.0"
: chloe-name? ( name -- ? ) : chloe-name? ( name -- ? )
url>> chloe-ns = ; url>> chloe-ns = ;

2
basis/io/backend/unix/unix.factor
View File

@ -77,7 +77,7 @@ M: io-timeout summary drop "I/O operation timed out" ;
'[ handle>> _ wait-for-fd ] with-timeout ; '[ handle>> _ wait-for-fd ] with-timeout ;
! Some general stuff ! Some general stuff
: file-mode OCT: 0666 ; CONSTANT: file-mode OCT: 0666
! Readers ! Readers
: (refill) ( port -- n ) : (refill) ( port -- n )

11
basis/io/encodings/8-bit/8-bit.factor
View File

@ -4,12 +4,12 @@ USING: math.parser arrays io.encodings sequences kernel assocs
hashtables io.encodings.ascii generic parser classes.tuple words hashtables io.encodings.ascii generic parser classes.tuple words
words.symbol io io.files splitting namespaces math words.symbol io io.files splitting namespaces math
compiler.units accessors classes.singleton classes.mixin compiler.units accessors classes.singleton classes.mixin
io.encodings.iana ; io.encodings.iana fry ;
IN: io.encodings.8-bit IN: io.encodings.8-bit
<PRIVATE <PRIVATE
: mappings { CONSTANT: mappings {
! encoding-name iana-name file-name ! encoding-name iana-name file-name
{ "latin1" "ISO_8859-1:1987" "8859-1" } { "latin1" "ISO_8859-1:1987" "8859-1" }
{ "latin2" "ISO_8859-2:1987" "8859-2" } { "latin2" "ISO_8859-2:1987" "8859-2" }
@ -30,11 +30,10 @@ IN: io.encodings.8-bit
{ "windows-1252" "windows-1252" "CP1252" } { "windows-1252" "windows-1252" "CP1252" }
{ "ebcdic" "IBM037" "CP037" } { "ebcdic" "IBM037" "CP037" }
{ "mac-roman" "macintosh" "ROMAN" } { "mac-roman" "macintosh" "ROMAN" }
} ; }
: encoding-file ( file-name -- stream ) : encoding-file ( file-name -- stream )
"vocab:io/encodings/8-bit/" swap ".TXT" "vocab:io/encodings/8-bit/" ".TXT" surround ;
3append ;
: process-contents ( lines -- assoc ) : process-contents ( lines -- assoc )
[ "#" split1 drop ] map harvest [ "#" split1 drop ] map harvest
@ -42,7 +41,7 @@ IN: io.encodings.8-bit
: byte>ch ( assoc -- array ) : byte>ch ( assoc -- array )
256 replacement-char <array> 256 replacement-char <array>
[ [ swapd set-nth ] curry assoc-each ] keep ; [ '[ swap _ set-nth ] assoc-each ] keep ;
: ch>byte ( assoc -- newassoc ) : ch>byte ( assoc -- newassoc )
[ swap ] assoc-map >hashtable ; [ swap ] assoc-map >hashtable ;

2
basis/logging/server/server.factor
View File

@ -63,7 +63,7 @@ SYMBOL: log-files
dup values [ try-dispose ] each dup values [ try-dispose ] each
clear-assoc ; clear-assoc ;
: keep-logs 10 ; CONSTANT: keep-logs 10
: ?delete-file ( path -- ) : ?delete-file ( path -- )
dup exists? [ delete-file ] [ drop ] if ; dup exists? [ delete-file ] [ drop ] if ;

4
basis/macros/macros.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects combinators assocs USING: parser kernel sequences words effects combinators assocs
definitions quotations namespaces memoize accessors ; definitions quotations namespaces memoize accessors ;
@ -7,7 +7,7 @@ IN: macros
<PRIVATE <PRIVATE
: real-macro-effect ( word -- effect' ) : real-macro-effect ( word -- effect' )
"declared-effect" word-prop in>> 1 <effect> ; stack-effect in>> 1 <effect> ;
PRIVATE> PRIVATE>

10
basis/math/quaternions/quaternions.factor
View File

@ -45,13 +45,13 @@ PRIVATE>
first2 [ imaginary-part ] dip >rect 3array ; first2 [ imaginary-part ] dip >rect 3array ;
! Zero ! Zero
: q0 { 0 0 } ; CONSTANT: q0 { 0 0 }
! Units ! Units
: q1 { 1 0 } ; CONSTANT: q1 { 1 0 }
: qi { C{ 0 1 } 0 } ; CONSTANT: qi { C{ 0 1 } 0 }
: qj { 0 1 } ; CONSTANT: qj { 0 1 }
: qk { 0 C{ 0 1 } } ; CONSTANT: qk { 0 C{ 0 1 } }
! Euler angles ! Euler angles

8
basis/memoize/memoize-tests.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel memoize tools.test parser generalizations USING: math kernel memoize tools.test parser generalizations
prettyprint io.streams.string sequences eval ; prettyprint io.streams.string sequences eval ;
@ -17,6 +17,10 @@ MEMO: see-test ( a -- b ) reverse ;
[ [ \ see-test see ] with-string-writer ] [ [ \ see-test see ] with-string-writer ]
unit-test unit-test
[ ] [ "IN: memoize.tests : fib ;" eval ] unit-test [ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test
[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test
[ sq ] (( a -- b )) memoize-quot "q" set
[ 9 ] [ 3 "q" get call ] unit-test

67
basis/memoize/memoize.factor
View File

@ -1,47 +1,45 @@
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables sequences arrays words namespaces make USING: kernel hashtables sequences arrays words namespaces make
parser math assocs effects definitions quotations summary parser math assocs effects definitions quotations summary
accessors ; accessors fry ;
IN: memoize IN: memoize
: packer ( n -- quot )
{ [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ;
: unpacker ( n -- quot )
{ [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
: #in ( word -- n )
stack-effect in>> length ;
: #out ( word -- n )
stack-effect out>> length ;
: pack/unpack ( quot word -- newquot )
[ dup #in unpacker % swap % #out packer % ] [ ] make ;
: make-memoizer ( quot word -- quot )
[
[ #in packer % ] keep
[ "memoize" word-prop , ] keep
[ pack/unpack , ] keep
\ cache ,
#out unpacker %
] [ ] make ;
ERROR: too-many-arguments ; ERROR: too-many-arguments ;
M: too-many-arguments summary M: too-many-arguments summary
drop "There must be no more than 4 input and 4 output arguments" ; drop "There must be no more than 4 input and 4 output arguments" ;
: check-memoized ( word -- ) <PRIVATE
[ #in ] [ #out ] bi [ 4 > ] either? [ too-many-arguments ] when ;
: packer ( seq -- quot )
length { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ;
: unpacker ( seq -- quot )
length { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
: pack/unpack ( quot effect -- newquot )
[ in>> packer ] [ out>> unpacker ] bi surround ;
: unpack/pack ( quot effect -- newquot )
[ in>> unpacker ] [ out>> packer ] bi surround ;
: check-memoized ( effect -- )
[ in>> ] [ out>> ] bi [ length 4 > ] either? [ too-many-arguments ] when ;
: make-memoizer ( table quot effect -- quot )
[ check-memoized ] keep
[ unpack/pack '[ _ _ cache ] ] keep
pack/unpack ;
PRIVATE>
: define-memoized ( word quot -- ) : define-memoized ( word quot -- )
over check-memoized [ H{ } clone ] dip
2dup "memo-quot" set-word-prop [ pick stack-effect make-memoizer define ]
over H{ } clone "memoize" set-word-prop [ nip "memo-quot" set-word-prop ]
over make-memoizer define ; [ drop "memoize" set-word-prop ]
3tri ;
: MEMO: (:) define-memoized ; parsing : MEMO: (:) define-memoized ; parsing
@ -57,11 +55,10 @@ M: memoized reset-word
bi ; bi ;
: memoize-quot ( quot effect -- memo-quot ) : memoize-quot ( quot effect -- memo-quot )
gensym swap dupd "declared-effect" set-word-prop [ H{ } clone ] 2dip make-memoizer ;
dup rot define-memoized 1quotation ;
: reset-memoized ( word -- ) : reset-memoized ( word -- )
"memoize" word-prop clear-assoc ; "memoize" word-prop clear-assoc ;
: invalidate-memoized ( inputs... word -- ) : invalidate-memoized ( inputs... word -- )
[ #in packer call ] [ "memoize" word-prop delete-at ] bi ; [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;

2
basis/none/none.factor
View File

@ -1,6 +1,6 @@
! Just a dummy shell for the -run switch... ! Just a dummy shell for the -run switch...
IN: none IN: none
: none ; : none ( -- ) ;
MAIN: none MAIN: none

294
basis/opengl/glu/glu.factor
View File

@ -11,183 +11,183 @@ TYPEDEF: void* GLubyte*
TYPEDEF: void* GLUfuncptr TYPEDEF: void* GLUfuncptr
! StringName ! StringName
: GLU_VERSION 100800 ; CONSTANT: GLU_VERSION 100800
: GLU_EXTENSIONS 100801 ; CONSTANT: GLU_EXTENSIONS 100801
! ErrorCode ! ErrorCode
: GLU_INVALID_ENUM 100900 ; CONSTANT: GLU_INVALID_ENUM 100900
: GLU_INVALID_VALUE 100901 ; CONSTANT: GLU_INVALID_VALUE 100901
: GLU_OUT_OF_MEMORY 100902 ; CONSTANT: GLU_OUT_OF_MEMORY 100902
: GLU_INCOMPATIBLE_GL_VERSION 100903 ; CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903
: GLU_INVALID_OPERATION 100904 ; CONSTANT: GLU_INVALID_OPERATION 100904
! NurbsDisplay ! NurbsDisplay
: GLU_OUTLINE_POLYGON 100240 ; CONSTANT: GLU_OUTLINE_POLYGON 100240
: GLU_OUTLINE_PATCH 100241 ; CONSTANT: GLU_OUTLINE_PATCH 100241
! NurbsCallback ! NurbsCallback
: GLU_NURBS_ERROR 100103 ; CONSTANT: GLU_NURBS_ERROR 100103
: GLU_ERROR 100103 ; CONSTANT: GLU_ERROR 100103
: GLU_NURBS_BEGIN 100164 ; CONSTANT: GLU_NURBS_BEGIN 100164
: GLU_NURBS_BEGIN_EXT 100164 ; CONSTANT: GLU_NURBS_BEGIN_EXT 100164
: GLU_NURBS_VERTEX 100165 ; CONSTANT: GLU_NURBS_VERTEX 100165
: GLU_NURBS_VERTEX_EXT 100165 ; CONSTANT: GLU_NURBS_VERTEX_EXT 100165
: GLU_NURBS_NORMAL 100166 ; CONSTANT: GLU_NURBS_NORMAL 100166
: GLU_NURBS_NORMAL_EXT 100166 ; CONSTANT: GLU_NURBS_NORMAL_EXT 100166
: GLU_NURBS_COLOR 100167 ; CONSTANT: GLU_NURBS_COLOR 100167
: GLU_NURBS_COLOR_EXT 100167 ; CONSTANT: GLU_NURBS_COLOR_EXT 100167
: GLU_NURBS_TEXTURE_COORD 100168 ; CONSTANT: GLU_NURBS_TEXTURE_COORD 100168
: GLU_NURBS_TEX_COORD_EXT 100168 ; CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168
: GLU_NURBS_END 100169 ; CONSTANT: GLU_NURBS_END 100169
: GLU_NURBS_END_EXT 100169 ; CONSTANT: GLU_NURBS_END_EXT 100169
: GLU_NURBS_BEGIN_DATA 100170 ; CONSTANT: GLU_NURBS_BEGIN_DATA 100170
: GLU_NURBS_BEGIN_DATA_EXT 100170 ; CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170
: GLU_NURBS_VERTEX_DATA 100171 ; CONSTANT: GLU_NURBS_VERTEX_DATA 100171
: GLU_NURBS_VERTEX_DATA_EXT 100171 ; CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171
: GLU_NURBS_NORMAL_DATA 100172 ; CONSTANT: GLU_NURBS_NORMAL_DATA 100172
: GLU_NURBS_NORMAL_DATA_EXT 100172 ; CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172
: GLU_NURBS_COLOR_DATA 100173 ; CONSTANT: GLU_NURBS_COLOR_DATA 100173
: GLU_NURBS_COLOR_DATA_EXT 100173 ; CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173
: GLU_NURBS_TEXTURE_COORD_DATA 100174 ; CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174
: GLU_NURBS_TEX_COORD_DATA_EXT 100174 ; CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174
: GLU_NURBS_END_DATA 100175 ; CONSTANT: GLU_NURBS_END_DATA 100175
: GLU_NURBS_END_DATA_EXT 100175 ; CONSTANT: GLU_NURBS_END_DATA_EXT 100175
! NurbsError ! NurbsError
: GLU_NURBS_ERROR1 100251 ; CONSTANT: GLU_NURBS_ERROR1 100251
: GLU_NURBS_ERROR2 100252 ; CONSTANT: GLU_NURBS_ERROR2 100252
: GLU_NURBS_ERROR3 100253 ; CONSTANT: GLU_NURBS_ERROR3 100253
: GLU_NURBS_ERROR4 100254 ; CONSTANT: GLU_NURBS_ERROR4 100254
: GLU_NURBS_ERROR5 100255 ; CONSTANT: GLU_NURBS_ERROR5 100255
: GLU_NURBS_ERROR6 100256 ; CONSTANT: GLU_NURBS_ERROR6 100256
: GLU_NURBS_ERROR7 100257 ; CONSTANT: GLU_NURBS_ERROR7 100257
: GLU_NURBS_ERROR8 100258 ; CONSTANT: GLU_NURBS_ERROR8 100258
: GLU_NURBS_ERROR9 100259 ; CONSTANT: GLU_NURBS_ERROR9 100259
: GLU_NURBS_ERROR10 100260 ; CONSTANT: GLU_NURBS_ERROR10 100260
: GLU_NURBS_ERROR11 100261 ; CONSTANT: GLU_NURBS_ERROR11 100261
: GLU_NURBS_ERROR12 100262 ; CONSTANT: GLU_NURBS_ERROR12 100262
: GLU_NURBS_ERROR13 100263 ; CONSTANT: GLU_NURBS_ERROR13 100263
: GLU_NURBS_ERROR14 100264 ; CONSTANT: GLU_NURBS_ERROR14 100264
: GLU_NURBS_ERROR15 100265 ; CONSTANT: GLU_NURBS_ERROR15 100265
: GLU_NURBS_ERROR16 100266 ; CONSTANT: GLU_NURBS_ERROR16 100266
: GLU_NURBS_ERROR17 100267 ; CONSTANT: GLU_NURBS_ERROR17 100267
: GLU_NURBS_ERROR18 100268 ; CONSTANT: GLU_NURBS_ERROR18 100268
: GLU_NURBS_ERROR19 100269 ; CONSTANT: GLU_NURBS_ERROR19 100269
: GLU_NURBS_ERROR20 100270 ; CONSTANT: GLU_NURBS_ERROR20 100270
: GLU_NURBS_ERROR21 100271 ; CONSTANT: GLU_NURBS_ERROR21 100271
: GLU_NURBS_ERROR22 100272 ; CONSTANT: GLU_NURBS_ERROR22 100272
: GLU_NURBS_ERROR23 100273 ; CONSTANT: GLU_NURBS_ERROR23 100273
: GLU_NURBS_ERROR24 100274 ; CONSTANT: GLU_NURBS_ERROR24 100274
: GLU_NURBS_ERROR25 100275 ; CONSTANT: GLU_NURBS_ERROR25 100275
: GLU_NURBS_ERROR26 100276 ; CONSTANT: GLU_NURBS_ERROR26 100276
: GLU_NURBS_ERROR27 100277 ; CONSTANT: GLU_NURBS_ERROR27 100277
: GLU_NURBS_ERROR28 100278 ; CONSTANT: GLU_NURBS_ERROR28 100278
: GLU_NURBS_ERROR29 100279 ; CONSTANT: GLU_NURBS_ERROR29 100279
: GLU_NURBS_ERROR30 100280 ; CONSTANT: GLU_NURBS_ERROR30 100280
: GLU_NURBS_ERROR31 100281 ; CONSTANT: GLU_NURBS_ERROR31 100281
: GLU_NURBS_ERROR32 100282 ; CONSTANT: GLU_NURBS_ERROR32 100282
: GLU_NURBS_ERROR33 100283 ; CONSTANT: GLU_NURBS_ERROR33 100283
: GLU_NURBS_ERROR34 100284 ; CONSTANT: GLU_NURBS_ERROR34 100284
: GLU_NURBS_ERROR35 100285 ; CONSTANT: GLU_NURBS_ERROR35 100285
: GLU_NURBS_ERROR36 100286 ; CONSTANT: GLU_NURBS_ERROR36 100286
: GLU_NURBS_ERROR37 100287 ; CONSTANT: GLU_NURBS_ERROR37 100287
! NurbsProperty ! NurbsProperty
: GLU_AUTO_LOAD_MATRIX 100200 ; CONSTANT: GLU_AUTO_LOAD_MATRIX 100200
: GLU_CULLING 100201 ; CONSTANT: GLU_CULLING 100201
: GLU_SAMPLING_TOLERANCE 100203 ; CONSTANT: GLU_SAMPLING_TOLERANCE 100203
: GLU_DISPLAY_MODE 100204 ; CONSTANT: GLU_DISPLAY_MODE 100204
: GLU_PARAMETRIC_TOLERANCE 100202 ; CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202
: GLU_SAMPLING_METHOD 100205 ; CONSTANT: GLU_SAMPLING_METHOD 100205
: GLU_U_STEP 100206 ; CONSTANT: GLU_U_STEP 100206
: GLU_V_STEP 100207 ; CONSTANT: GLU_V_STEP 100207
: GLU_NURBS_MODE 100160 ; CONSTANT: GLU_NURBS_MODE 100160
: GLU_NURBS_MODE_EXT 100160 ; CONSTANT: GLU_NURBS_MODE_EXT 100160
: GLU_NURBS_TESSELLATOR 100161 ; CONSTANT: GLU_NURBS_TESSELLATOR 100161
: GLU_NURBS_TESSELLATOR_EXT 100161 ; CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161
: GLU_NURBS_RENDERER 100162 ; CONSTANT: GLU_NURBS_RENDERER 100162
: GLU_NURBS_RENDERER_EXT 100162 ; CONSTANT: GLU_NURBS_RENDERER_EXT 100162
! NurbsSampling ! NurbsSampling
: GLU_OBJECT_PARAMETRIC_ERROR 100208 ; CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208
: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208 ; CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208
: GLU_OBJECT_PATH_LENGTH 100209 ; CONSTANT: GLU_OBJECT_PATH_LENGTH 100209
: GLU_OBJECT_PATH_LENGTH_EXT 100209 ; CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209
: GLU_PATH_LENGTH 100215 ; CONSTANT: GLU_PATH_LENGTH 100215
: GLU_PARAMETRIC_ERROR 100216 ; CONSTANT: GLU_PARAMETRIC_ERROR 100216
: GLU_DOMAIN_DISTANCE 100217 ; CONSTANT: GLU_DOMAIN_DISTANCE 100217
! NurbsTrim ! NurbsTrim
: GLU_MAP1_TRIM_2 100210 ; CONSTANT: GLU_MAP1_TRIM_2 100210
: GLU_MAP1_TRIM_3 100211 ; CONSTANT: GLU_MAP1_TRIM_3 100211
! QuadricDrawStyle ! QuadricDrawStyle
: GLU_POINT 100010 ; CONSTANT: GLU_POINT 100010
: GLU_LINE 100011 ; CONSTANT: GLU_LINE 100011
: GLU_FILL 100012 ; CONSTANT: GLU_FILL 100012
: GLU_SILHOUETTE 100013 ; CONSTANT: GLU_SILHOUETTE 100013
! QuadricNormal ! QuadricNormal
: GLU_SMOOTH 100000 ; CONSTANT: GLU_SMOOTH 100000
: GLU_FLAT 100001 ; CONSTANT: GLU_FLAT 100001
: GLU_NONE 100002 ; CONSTANT: GLU_NONE 100002
! QuadricOrientation ! QuadricOrientation
: GLU_OUTSIDE 100020 ; CONSTANT: GLU_OUTSIDE 100020
: GLU_INSIDE 100021 ; CONSTANT: GLU_INSIDE 100021
! TessCallback ! TessCallback
: GLU_TESS_BEGIN 100100 ; CONSTANT: GLU_TESS_BEGIN 100100
: GLU_BEGIN 100100 ; CONSTANT: GLU_BEGIN 100100
: GLU_TESS_VERTEX 100101 ; CONSTANT: GLU_TESS_VERTEX 100101
: GLU_VERTEX 100101 ; CONSTANT: GLU_VERTEX 100101
: GLU_TESS_END 100102 ; CONSTANT: GLU_TESS_END 100102
: GLU_END 100102 ; CONSTANT: GLU_END 100102
: GLU_TESS_ERROR 100103 ; CONSTANT: GLU_TESS_ERROR 100103
: GLU_TESS_EDGE_FLAG 100104 ; CONSTANT: GLU_TESS_EDGE_FLAG 100104
: GLU_EDGE_FLAG 100104 ; CONSTANT: GLU_EDGE_FLAG 100104
: GLU_TESS_COMBINE 100105 ; CONSTANT: GLU_TESS_COMBINE 100105
: GLU_TESS_BEGIN_DATA 100106 ; CONSTANT: GLU_TESS_BEGIN_DATA 100106
: GLU_TESS_VERTEX_DATA 100107 ; CONSTANT: GLU_TESS_VERTEX_DATA 100107
: GLU_TESS_END_DATA 100108 ; CONSTANT: GLU_TESS_END_DATA 100108
: GLU_TESS_ERROR_DATA 100109 ; CONSTANT: GLU_TESS_ERROR_DATA 100109
: GLU_TESS_EDGE_FLAG_DATA 100110 ; CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110
: GLU_TESS_COMBINE_DATA 100111 ; CONSTANT: GLU_TESS_COMBINE_DATA 100111
! TessContour ! TessContour
: GLU_CW 100120 ; CONSTANT: GLU_CW 100120
: GLU_CCW 100121 ; CONSTANT: GLU_CCW 100121
: GLU_INTERIOR 100122 ; CONSTANT: GLU_INTERIOR 100122
: GLU_EXTERIOR 100123 ; CONSTANT: GLU_EXTERIOR 100123
: GLU_UNKNOWN 100124 ; CONSTANT: GLU_UNKNOWN 100124
! TessProperty ! TessProperty
: GLU_TESS_WINDING_RULE 100140 ; CONSTANT: GLU_TESS_WINDING_RULE 100140
: GLU_TESS_BOUNDARY_ONLY 100141 ; CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141
: GLU_TESS_TOLERANCE 100142 ; CONSTANT: GLU_TESS_TOLERANCE 100142
! TessError ! TessError
: GLU_TESS_ERROR1 100151 ; CONSTANT: GLU_TESS_ERROR1 100151
: GLU_TESS_ERROR2 100152 ; CONSTANT: GLU_TESS_ERROR2 100152
: GLU_TESS_ERROR3 100153 ; CONSTANT: GLU_TESS_ERROR3 100153
: GLU_TESS_ERROR4 100154 ; CONSTANT: GLU_TESS_ERROR4 100154
: GLU_TESS_ERROR5 100155 ; CONSTANT: GLU_TESS_ERROR5 100155
: GLU_TESS_ERROR6 100156 ; CONSTANT: GLU_TESS_ERROR6 100156
: GLU_TESS_ERROR7 100157 ; CONSTANT: GLU_TESS_ERROR7 100157
: GLU_TESS_ERROR8 100158 ; CONSTANT: GLU_TESS_ERROR8 100158
: GLU_TESS_MISSING_BEGIN_POLYGON 100151 ; CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151
: GLU_TESS_MISSING_BEGIN_CONTOUR 100152 ; CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152
: GLU_TESS_MISSING_END_POLYGON 100153 ; CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153
: GLU_TESS_MISSING_END_CONTOUR 100154 ; CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154
: GLU_TESS_COORD_TOO_LARGE 100155 ; CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155
: GLU_TESS_NEED_COMBINE_CALLBACK 100156 ; CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156
! TessWinding ! TessWinding
: GLU_TESS_WINDING_ODD 100130 ; CONSTANT: GLU_TESS_WINDING_ODD 100130
: GLU_TESS_WINDING_NONZERO 100131 ; CONSTANT: GLU_TESS_WINDING_NONZERO 100131
: GLU_TESS_WINDING_POSITIVE 100132 ; CONSTANT: GLU_TESS_WINDING_POSITIVE 100132
: GLU_TESS_WINDING_NEGATIVE 100133 ; CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133
: GLU_TESS_WINDING_ABS_GEQ_TWO 100134 ; CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134
LIBRARY: glu LIBRARY: glu

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

@ -99,7 +99,7 @@ FUNCTION: void* BIO_f_buffer ( ) ;
! evp.h ! evp.h
! =============================================== ! ===============================================
: EVP_MAX_MD_SIZE 64 ; CONSTANT: EVP_MAX_MD_SIZE 64
C-STRUCT: EVP_MD_CTX C-STRUCT: EVP_MD_CTX
{ "EVP_MD*" "digest" } { "EVP_MD*" "digest" }

4
basis/peg/parsers/parsers.factor
View File

@ -7,12 +7,12 @@ IN: peg.parsers
TUPLE: just-parser p1 ; TUPLE: just-parser p1 ;
: just-pattern CONSTANT: just-pattern
[ [
execute dup [ execute dup [
dup remaining>> empty? [ drop f ] unless dup remaining>> empty? [ drop f ] unless
] when ] when
] ; ]
M: just-parser (compile) ( parser -- quot ) M: just-parser (compile) ( parser -- quot )

57
basis/stack-checker/backend/backend.factor
View File

@ -124,18 +124,13 @@ M: object apply-object push-literal ;
: undo-infer ( -- ) : undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ; recorded get [ f "inferred-effect" set-word-prop ] each ;
: consume/produce ( effect quot -- ) : (consume/produce) ( effect -- inputs outputs )
#! quot is ( inputs outputs -- ) [ in>> length consume-d ] [ out>> length produce-d ] bi ;
[
[ : consume/produce ( effect quot: ( inputs outputs -- ) -- )
[ in>> length consume-d ] '[ (consume/produce) @ ]
[ out>> length produce-d ] [ terminated?>> [ terminate ] when ]
bi bi ; inline
] dip call
] [
drop
terminated?>> [ terminate ] when
] 2bi ; inline
: infer-word-def ( word -- ) : infer-word-def ( word -- )
[ specialized-def ] [ add-recursive-state ] bi infer-quot ; [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
@ -143,30 +138,18 @@ M: object apply-object push-literal ;
: end-infer ( -- ) : end-infer ( -- )
meta-d clone #return, ; meta-d clone #return, ;
: effect-required? ( word -- ? ) : required-stack-effect ( word -- effect )
{ dup stack-effect [ ] [ missing-effect inference-error ] ?if ;
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
[ def>> [ word? ] any? ]
} cond ;
: ?missing-effect ( word -- )
dup effect-required?
[ missing-effect inference-error ] [ drop ] if ;
: check-effect ( word effect -- ) : check-effect ( word effect -- )
over stack-effect { over required-stack-effect 2dup effect<=
{ [ dup not ] [ 2drop ?missing-effect ] } [ 3drop ] [ effect-error ] if ;
{ [ 2dup effect<= ] [ 3drop ] }
[ effect-error ]
} cond ;
: finish-word ( word -- ) : finish-word ( word -- )
current-effect [ current-effect check-effect ]
[ check-effect ] [ recorded get push ]
[ drop recorded get push ] [ t "inferred-effect" set-word-prop ]
[ "inferred-effect" set-word-prop ] tri ;
2tri ;
: cannot-infer-effect ( word -- * ) : cannot-infer-effect ( word -- * )
"cannot-infer" word-prop throw ; "cannot-infer" word-prop throw ;
@ -183,22 +166,20 @@ M: object apply-object push-literal ;
dependencies off dependencies off
generic-dependencies off generic-dependencies off
[ infer-word-def end-infer ] [ infer-word-def end-infer ]
[ finish-word current-effect ] [ finish-word ]
bi [ stack-effect ]
tri
] with-scope ] with-scope
] maybe-cannot-infer ; ] maybe-cannot-infer ;
: apply-word/effect ( word effect -- ) : apply-word/effect ( word effect -- )
swap '[ _ #call, ] consume/produce ; swap '[ _ #call, ] consume/produce ;
: required-stack-effect ( word -- effect )
dup stack-effect [ ] [ \ missing-effect inference-error ] ?if ;
: call-recursive-word ( word -- ) : call-recursive-word ( word -- )
dup required-stack-effect apply-word/effect ; dup required-stack-effect apply-word/effect ;
: cached-infer ( word -- ) : cached-infer ( word -- )
dup "inferred-effect" word-prop apply-word/effect ; dup stack-effect apply-word/effect ;
: with-infer ( quot -- effect visitor ) : with-infer ( quot -- effect visitor )
[ [

6
basis/stack-checker/known-words/known-words.factor
View File

@ -319,12 +319,18 @@ M: object infer-call*
\ fixnum/i { fixnum fixnum } { integer } define-primitive \ fixnum/i { fixnum fixnum } { integer } define-primitive
\ fixnum/i make-foldable \ fixnum/i make-foldable
\ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive
\ fixnum/i-fast make-foldable
\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive \ fixnum-mod { fixnum fixnum } { fixnum } define-primitive
\ fixnum-mod make-foldable \ fixnum-mod make-foldable
\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive \ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive
\ fixnum/mod make-foldable \ fixnum/mod make-foldable
\ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive
\ fixnum/mod-fast make-foldable
\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive
\ fixnum-bitand make-foldable \ fixnum-bitand make-foldable

2
basis/threads/threads.factor
View File

@ -118,7 +118,7 @@ DEFER: stop
[ ] while [ ] while
drop ; drop ;
: start ( namestack thread -- ) : start ( namestack thread -- * )
[ [
set-self set-self
set-namestack set-namestack

8
basis/tools/deploy/config/config.factor
View File

@ -14,12 +14,12 @@ SYMBOL: deploy-threads?
SYMBOL: deploy-io SYMBOL: deploy-io
: deploy-io-options CONSTANT: deploy-io-options
{ {
{ 1 "Level 1 - No input/output" } { 1 "Level 1 - No input/output" }
{ 2 "Level 2 - Basic ANSI C streams" } { 2 "Level 2 - Basic ANSI C streams" }
{ 3 "Level 3 - Non-blocking streams and networking" } { 3 "Level 3 - Non-blocking streams and networking" }
} ; }
: strip-io? ( -- ? ) deploy-io get 1 = ; : strip-io? ( -- ? ) deploy-io get 1 = ;
@ -27,7 +27,7 @@ SYMBOL: deploy-io
SYMBOL: deploy-reflection SYMBOL: deploy-reflection
: deploy-reflection-options CONSTANT: deploy-reflection-options
{ {
{ 1 "Level 1 - No reflection" } { 1 "Level 1 - No reflection" }
{ 2 "Level 2 - Retain word names" } { 2 "Level 2 - Retain word names" }
@ -35,7 +35,7 @@ SYMBOL: deploy-reflection
{ 4 "Level 4 - Debugger" } { 4 "Level 4 - Debugger" }
{ 5 "Level 5 - Parser" } { 5 "Level 5 - Parser" }
{ 6 "Level 6 - Full environment" } { 6 "Level 6 - Full environment" }
} ; }
: strip-word-names? ( -- ? ) deploy-reflection get 2 < ; : strip-word-names? ( -- ? ) deploy-reflection get 2 < ;
: strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ; : strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ;

4
basis/tools/deploy/shaker/shaker.factor
View File

@ -95,7 +95,7 @@ IN: tools.deploy.shaker
"cannot-infer" "cannot-infer"
"coercer" "coercer"
"combination" "combination"
"compiled-effect" "compiled-status"
"compiled-generic-uses" "compiled-generic-uses"
"compiled-uses" "compiled-uses"
"constraints" "constraints"
@ -190,7 +190,7 @@ IN: tools.deploy.shaker
"Stripping default methods" show "Stripping default methods" show
[ [
[ generic? ] instances [ generic? ] instances
[ "No method" throw ] define-temp [ "No method" throw ] (( -- * )) define-temp
dup t "default" set-word-prop dup t "default" set-word-prop
'[ '[
[ _ "default-method" set-word-prop ] [ make-generic ] bi [ _ "default-method" set-word-prop ] [ make-generic ] bi

2
basis/tools/profiler/profiler-tests.factor
View File

@ -1,6 +1,6 @@
IN: tools.profiler.tests IN: tools.profiler.tests
USING: accessors tools.profiler tools.test kernel memory math USING: accessors tools.profiler tools.test kernel memory math
threads alien tools.profiler.private sequences compiler.units threads alien tools.profiler.private sequences compiler
words ; words ;
[ t ] [ [ t ] [

14
basis/ui/backend/windows/windows.factor
View File

@ -104,7 +104,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
[ lo-word ] keep hi-word 2array [ lo-word ] keep hi-word 2array
swap window (>>window-loc) ; swap window (>>window-loc) ;
: wm-keydown-codes ( -- key ) CONSTANT: wm-keydown-codes
H{ H{
{ 8 "BACKSPACE" } { 8 "BACKSPACE" }
{ 9 "TAB" } { 9 "TAB" }
@ -132,7 +132,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
{ 121 "F10" } { 121 "F10" }
{ 122 "F11" } { 122 "F11" }
{ 123 "F12" } { 123 "F12" }
} ; }
: key-state-down? ( key -- ? ) : key-state-down? ( key -- ? )
GetKeyState 16 bit? ; GetKeyState 16 bit? ;
@ -155,22 +155,22 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
alt? [ A+ , ] when alt? [ A+ , ] when
] { } make [ empty? not ] keep f ? ; ] { } make [ empty? not ] keep f ? ;
: exclude-keys-wm-keydown CONSTANT: exclude-keys-wm-keydown
H{ H{
{ 16 "SHIFT" } { 16 "SHIFT" }
{ 17 "CTRL" } { 17 "CTRL" }
{ 18 "ALT" } { 18 "ALT" }
{ 20 "CAPS-LOCK" } { 20 "CAPS-LOCK" }
} ; }
: exclude-keys-wm-char ! Values are ignored
! Values are ignored CONSTANT: exclude-keys-wm-char
H{ H{
{ 8 "BACKSPACE" } { 8 "BACKSPACE" }
{ 9 "TAB" } { 9 "TAB" }
{ 13 "RET" } { 13 "RET" }
{ 27 "ESC" } { 27 "ESC" }
} ; }
: exclude-key-wm-keydown? ( n -- ? ) : exclude-key-wm-keydown? ( n -- ? )
exclude-keys-wm-keydown key? ; exclude-keys-wm-keydown key? ;

12
basis/ui/backend/x11/x11.factor
View File

@ -29,14 +29,14 @@ M: world configure-event
! In case dimensions didn't change ! In case dimensions didn't change
relayout-1 ; relayout-1 ;
: modifiers CONSTANT: modifiers
{ {
{ S+ HEX: 1 } { S+ HEX: 1 }
{ C+ HEX: 4 } { C+ HEX: 4 }
{ A+ HEX: 8 } { A+ HEX: 8 }
} ; }
: key-codes CONSTANT: key-codes
H{ H{
{ HEX: FF08 "BACKSPACE" } { HEX: FF08 "BACKSPACE" }
{ HEX: FF09 "TAB" } { HEX: FF09 "TAB" }
@ -62,7 +62,7 @@ M: world configure-event
{ HEX: FFC4 "F7" } { HEX: FFC4 "F7" }
{ HEX: FFC5 "F8" } { HEX: FFC5 "F8" }
{ HEX: FFC6 "F9" } { HEX: FFC6 "F9" }
} ; }
: key-code ( keysym -- keycode action? ) : key-code ( keysym -- keycode action? )
dup key-codes at [ t ] [ 1string f ] ?if ; dup key-codes at [ t ] [ 1string f ] ?if ;
@ -91,7 +91,7 @@ M: world key-down-event
3bi ; 3bi ;
: key-up-event>gesture ( event -- gesture ) : key-up-event>gesture ( event -- gesture )
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ; [ event-modifiers ] [ 0 XLookupKeysym key-code ] bi <key-up> ;
M: world key-up-event M: world key-up-event
[ key-up-event>gesture ] dip propagate-key-gesture ; [ key-up-event>gesture ] dip propagate-key-gesture ;

3
basis/ui/gadgets/frames/frames.factor
View File

@ -22,9 +22,6 @@ M: glue pref-dim* drop { 0 0 } ;
: (fill- ( frame grid-layout quot1 quot2 -- pref-dim gap filled-cell dims ) : (fill- ( frame grid-layout quot1 quot2 -- pref-dim gap filled-cell dims )
[ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline [ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline
: available-space ( pref-dim gap dims -- avail )
length 1+ * [-] ; inline
: -center) ( pref-dim gap filled-cell dims -- ) : -center) ( pref-dim gap filled-cell dims -- )
[ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline [ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline

2
basis/ui/render/render.factor
View File

@ -112,4 +112,4 @@ M: gadget draw-children
CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 } CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
CONSTANT: focus-border-color COLOR: dark-gray CONSTANT: focus-border-color COLOR: dark-gray

297
basis/ui/x11/x11.factor Executable file
View File

@ -0,0 +1,297 @@
! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays ui ui.gadgets
ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
ui.event-loop assocs kernel math namespaces opengl sequences
strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
x11.constants x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators command-line
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ascii ;
IN: ui.x11
SINGLETON: x11-ui-backend
: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
TUPLE: x11-handle-base glx ;
TUPLE: x11-handle < x11-handle-base xic window ;
TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
C: <x11-handle> x11-handle
C: <x11-pixmap-handle> x11-pixmap-handle
M: world expose-event nip relayout ;
M: world configure-event
over configured-loc >>window-loc
swap configured-dim >>dim
! In case dimensions didn't change
relayout-1 ;
CONSTANT: modifiers
{
{ S+ HEX: 1 }
{ C+ HEX: 4 }
{ A+ HEX: 8 }
}
CONSTANT: key-codes
H{
{ HEX: FF08 "BACKSPACE" }
{ HEX: FF09 "TAB" }
{ HEX: FF0D "RET" }
{ HEX: FF8D "ENTER" }
{ HEX: FF1B "ESC" }
{ HEX: FFFF "DELETE" }
{ HEX: FF50 "HOME" }
{ HEX: FF51 "LEFT" }
{ HEX: FF52 "UP" }
{ HEX: FF53 "RIGHT" }
{ HEX: FF54 "DOWN" }
{ HEX: FF55 "PAGE_UP" }
{ HEX: FF56 "PAGE_DOWN" }
{ HEX: FF57 "END" }
{ HEX: FF58 "BEGIN" }
{ HEX: FFBE "F1" }
{ HEX: FFBF "F2" }
{ HEX: FFC0 "F3" }
{ HEX: FFC1 "F4" }
{ HEX: FFC2 "F5" }
{ HEX: FFC3 "F6" }
{ HEX: FFC4 "F7" }
{ HEX: FFC5 "F8" }
{ HEX: FFC6 "F9" }
}
: key-code ( keysym -- keycode action? )
dup key-codes at [ t ] [ 1string f ] ?if ;
: event-modifiers ( event -- seq )
XKeyEvent-state modifiers modifier ;
: valid-input? ( string gesture -- ? )
over empty? [ 2drop f ] [
mods>> { f { S+ } } member? [
[ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
] [
[ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
] if
] if ;
: key-down-event>gesture ( event world -- string gesture )
dupd
handle>> xic>> lookup-string
[ swap event-modifiers ] dip key-code <key-down> ;
M: world key-down-event
[ key-down-event>gesture ] keep
[ propagate-key-gesture drop ]
[ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
3bi ;
: key-up-event>gesture ( event -- gesture )
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
M: world key-up-event
[ key-up-event>gesture ] dip propagate-key-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
[ event-modifiers ]
[ XButtonEvent-button ]
[ mouse-event-loc ]
tri ;
M: world button-down-event
[ mouse-event>gesture [ <button-down> ] dip ] dip
send-button-down ;
M: world button-up-event
[ mouse-event>gesture [ <button-up> ] dip ] dip
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
XButtonEvent-button {
{ 4 { 0 -1 } }
{ 5 { 0 1 } }
{ 6 { -1 0 } }
{ 7 { 1 0 } }
} at ;
M: world wheel-event
[ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
send-wheel ;
M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ;
M: world motion-event
[ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
move-hand fire-motion ;
M: world focus-in-event
nip
dup handle>> xic>> XSetICFocus focus-world ;
M: world focus-out-event
nip
dup handle>> xic>> XUnsetICFocus unfocus-world ;
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
user-input ;
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
[ x-atom = ] with any? ;
: clipboard-for-atom ( atom -- clipboard )
{
{ XA_PRIMARY [ selection get ] }
{ XA_CLIPBOARD [ clipboard get ] }
[ drop <clipboard> ]
} case ;
: encode-clipboard ( string type -- bytes )
XSelectionRequestEvent-target
XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap
[ XSelectionRequestEvent-requestor ] keep
[ XSelectionRequestEvent-property ] keep
[ XSelectionRequestEvent-target ] keep
[ 8 PropModeReplace ] dip
[
XSelectionRequestEvent-selection
clipboard-for-atom contents>>
] keep encode-clipboard dup length XChangeProperty drop ;
M: world selection-request-event
drop dup XSelectionRequestEvent-target {
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
[ drop send-notify-failure ]
} cond ;
M: x11-ui-backend (close-window) ( handle -- )
dup xic>> XDestroyIC
dup glx>> destroy-glx
window>> dup unregister-window
destroy-window ;
M: world client-event
swap close-box? [ ungraft ] [ drop ] if ;
: gadget-window ( world -- )
dup window-loc>> over rect-dim glx-window
over "Factor" create-xic rot <x11-handle>
2dup window>> register-window
>>handle drop ;
: wait-event ( -- event )
QueuedAfterFlush events-queued 0 > [
next-event dup
None XFilterEvent zero? [ drop wait-event ] unless
] [
ui-wait wait-event
] if ;
M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup
[ handle-event ] [ 2drop ] if ;
: x-clipboard@ ( gadget clipboard -- prop win )
atom>> swap
find-world handle>> window>> ;
M: x-clipboard copy-clipboard
[ x-clipboard@ own-selection ] keep
(>>contents) ;
M: x-clipboard paste-clipboard
[ find-world handle>> window>> ] dip atom>> convert-selection ;
: init-clipboard ( -- )
XA_PRIMARY <x-clipboard> selection set-global
XA_CLIPBOARD <x-clipboard> clipboard set-global ;
: set-title-old ( dpy window string -- )
dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
: set-title-new ( dpy window string -- )
[ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
utf8 encode dup length XChangeProperty drop ;
M: x11-ui-backend set-title ( string world -- )
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
M: x11-ui-backend set-fullscreen* ( ? world -- )
handle>> window>> "XClientMessageEvent" <c-object>
tuck set-XClientMessageEvent-window
swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
over set-XClientMessageEvent-data0
ClientMessage over set-XClientMessageEvent-type
dpy get over set-XClientMessageEvent-display
"_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
32 over set-XClientMessageEvent-format
"_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
[ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
handle>> window>> dup set-closable map-window ;
M: x11-ui-backend raise-window* ( world -- )
handle>> [
dpy get swap window>> XRaiseWindow drop
] when* ;
M: x11-handle select-gl-context ( handle -- )
dpy get swap
[ window>> ] [ glx>> ] bi glXMakeCurrent
[ "Failed to set current GLX context" throw ] unless ;
M: x11-handle flush-gl-context ( handle -- )
dpy get swap window>> glXSwapBuffers ;
M: x11-pixmap-handle select-gl-context ( handle -- )
dpy get swap
[ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
[ "Failed to set current GLX context" throw ] unless ;
M: x11-pixmap-handle flush-gl-context ( handle -- )
drop ;
M: x11-ui-backend (open-offscreen-buffer) ( world -- )
dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
dpy get swap
[ glx-pixmap>> glXDestroyGLXPixmap ]
[ pixmap>> XFreePixmap drop ]
[ glx>> glXDestroyContext ] 2tri ;
M: x11-ui-backend offscreen-pixels ( world -- alien w h )
[ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
M: x11-ui-backend ui ( -- )
[
f [
[
init-clipboard
start-ui
event-loop
] with-xim
] with-x
] ui-running ;
M: x11-ui-backend beep ( -- )
dpy get 100 XBell drop ;
x11-ui-backend ui-backend set-global
[ "DISPLAY" os-env "ui" "listener" ? ]
main-vocab-hook set-global

8
basis/unicode/data/data.factor
View File

@ -97,8 +97,8 @@ VALUE: properties
[ nip zero? not ] assoc-filter [ nip zero? not ] assoc-filter
>hashtable ; >hashtable ;
: categories ( -- names ) ! For non-existent characters, use Cn
! For non-existent characters, use Cn CONSTANT: categories
{ "Cn" { "Cn"
"Lu" "Ll" "Lt" "Lm" "Lo" "Lu" "Ll" "Lt" "Lm" "Lo"
"Mn" "Mc" "Me" "Mn" "Mc" "Me"
@ -106,9 +106,9 @@ VALUE: properties
"Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po" "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"
"Sm" "Sc" "Sk" "So" "Sm" "Sc" "Sk" "So"
"Zs" "Zl" "Zp" "Zs" "Zl" "Zp"
"Cc" "Cf" "Cs" "Co" } ; "Cc" "Cf" "Cs" "Co" }
: num-chars HEX: 2FA1E ; CONSTANT: num-chars HEX: 2FA1E
! the maximum unicode char in the first 3 planes ! the maximum unicode char in the first 3 planes

4
basis/windows/kernel32/kernel32.factor
View File

@ -993,8 +993,8 @@ FUNCTION: BOOL DuplicateHandle (
BOOL bInheritHandle, BOOL bInheritHandle,
DWORD dwOptions ) ; DWORD dwOptions ) ;
: DUPLICATE_CLOSE_SOURCE 1 ; CONSTANT: DUPLICATE_CLOSE_SOURCE 1
: DUPLICATE_SAME_ACCESS 2 ; CONSTANT: DUPLICATE_SAME_ACCESS 2
! FUNCTION: EncodePointer ! FUNCTION: EncodePointer
! FUNCTION: EncodeSystemPointer ! FUNCTION: EncodeSystemPointer

5
basis/windows/winsock/winsock.factor Normal file → Executable file
View File

@ -257,12 +257,11 @@ TYPEDEF: WSANAMESPACE_INFOW WSANAMESPACE_INFO
TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
: FD_MAX_EVENTS 10 ; CONSTANT: FD_MAX_EVENTS 10
C-STRUCT: WSANETWORKEVENTS C-STRUCT: WSANETWORKEVENTS
{ "long" "lNetworkEvents" } { "long" "lNetworkEvents" }
! { { "int" "FD_MAX_EVENTS" } "iErrorCode" } ; { { "int" FD_MAX_EVENTS } "iErrorCode" } ;
{ { "int" 10 } "iErrorCode" } ;
TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS

350
basis/x11/constants/constants.factor
View File

@ -12,17 +12,17 @@ TYPEDEF: uchar KeyCode
! Reserved Resource and Constant Definitions ! Reserved Resource and Constant Definitions
: ParentRelative 1 ; CONSTANT: ParentRelative 1
: CopyFromParent 0 ; CONSTANT: CopyFromParent 0
: PointerWindow 0 ; CONSTANT: PointerWindow 0
: InputFocus 1 ; CONSTANT: InputFocus 1
: PointerRoot 1 ; CONSTANT: PointerRoot 1
: AnyPropertyType 0 ; CONSTANT: AnyPropertyType 0
: AnyKey 0 ; CONSTANT: AnyKey 0
: AnyButton 0 ; CONSTANT: AnyButton 0
: AllTemporary 0 ; CONSTANT: AllTemporary 0
: CurrentTime 0 ; CONSTANT: CurrentTime 0
: NoSymbol 0 ; CONSTANT: NoSymbol 0
! Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer, ! Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer,
! state in various key-, mouse-, and button-related events. ! state in various key-, mouse-, and button-related events.
@ -31,14 +31,14 @@ TYPEDEF: uchar KeyCode
! modifier names. Used to build a SetModifierMapping request or ! modifier names. Used to build a SetModifierMapping request or
! to read a GetModifierMapping request. These correspond to the ! to read a GetModifierMapping request. These correspond to the
! masks defined above. ! masks defined above.
: ShiftMapIndex 0 ; CONSTANT: ShiftMapIndex 0
: LockMapIndex 1 ; CONSTANT: LockMapIndex 1
: ControlMapIndex 2 ; CONSTANT: ControlMapIndex 2
: Mod1MapIndex 3 ; CONSTANT: Mod1MapIndex 3
: Mod2MapIndex 4 ; CONSTANT: Mod2MapIndex 4
: Mod3MapIndex 5 ; CONSTANT: Mod3MapIndex 5
: Mod4MapIndex 6 ; CONSTANT: Mod4MapIndex 6
: Mod5MapIndex 7 ; CONSTANT: Mod5MapIndex 7
! button masks. Used in same manner as Key masks above. Not to be confused ! button masks. Used in same manner as Key masks above. Not to be confused
@ -53,100 +53,100 @@ TYPEDEF: uchar KeyCode
! Notify modes ! Notify modes
: NotifyNormal 0 ; CONSTANT: NotifyNormal 0
: NotifyGrab 1 ; CONSTANT: NotifyGrab 1
: NotifyUngrab 2 ; CONSTANT: NotifyUngrab 2
: NotifyWhileGrabbed 3 ; CONSTANT: NotifyWhileGrabbed 3
: NotifyHint 1 ; ! for MotionNotify events CONSTANT: NotifyHint 1 ! for MotionNotify events
! Notify detail ! Notify detail
: NotifyAncestor 0 ; CONSTANT: NotifyAncestor 0
: NotifyVirtual 1 ; CONSTANT: NotifyVirtual 1
: NotifyInferior 2 ; CONSTANT: NotifyInferior 2
: NotifyNonlinear 3 ; CONSTANT: NotifyNonlinear 3
: NotifyNonlinearVirtual 4 ; CONSTANT: NotifyNonlinearVirtual 4
: NotifyPointer 5 ; CONSTANT: NotifyPointer 5
: NotifyPointerRoot 6 ; CONSTANT: NotifyPointerRoot 6
: NotifyDetailNone 7 ; CONSTANT: NotifyDetailNone 7
! Visibility notify ! Visibility notify
: VisibilityUnobscured 0 ; CONSTANT: VisibilityUnobscured 0
: VisibilityPartiallyObscured 1 ; CONSTANT: VisibilityPartiallyObscured 1
: VisibilityFullyObscured 2 ; CONSTANT: VisibilityFullyObscured 2
! Circulation request ! Circulation request
: PlaceOnTop 0 ; CONSTANT: PlaceOnTop 0
: PlaceOnBottom 1 ; CONSTANT: PlaceOnBottom 1
! protocol families ! protocol families
: FamilyInternet 0 ; ! IPv4 CONSTANT: FamilyInternet 0 ! IPv4
: FamilyDECnet 1 ; CONSTANT: FamilyDECnet 1
: FamilyChaos 2 ; CONSTANT: FamilyChaos 2
: FamilyInternet6 6 ; ! IPv6 CONSTANT: FamilyInternet6 6 ! IPv6
! authentication families not tied to a specific protocol ! authentication families not tied to a specific protocol
: FamilyServerInterpreted 5 ; CONSTANT: FamilyServerInterpreted 5
! Property notification ! Property notification
: PropertyNewValue 0 ; CONSTANT: PropertyNewValue 0
: PropertyDelete 1 ; CONSTANT: PropertyDelete 1
! Color Map notification ! Color Map notification
: ColormapUninstalled 0 ; CONSTANT: ColormapUninstalled 0
: ColormapInstalled 1 ; CONSTANT: ColormapInstalled 1
! GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes ! GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes
: GrabModeSync 0 ; CONSTANT: GrabModeSync 0
: GrabModeAsync 1 ; CONSTANT: GrabModeAsync 1
! GrabPointer, GrabKeyboard reply status ! GrabPointer, GrabKeyboard reply status
: GrabSuccess 0 ; CONSTANT: GrabSuccess 0
: AlreadyGrabbed 1 ; CONSTANT: AlreadyGrabbed 1
: GrabInvalidTime 2 ; CONSTANT: GrabInvalidTime 2
: GrabNotViewable 3 ; CONSTANT: GrabNotViewable 3
: GrabFrozen 4 ; CONSTANT: GrabFrozen 4
! AllowEvents modes ! AllowEvents modes
: AsyncPointer 0 ; CONSTANT: AsyncPointer 0
: SyncPointer 1 ; CONSTANT: SyncPointer 1
: ReplayPointer 2 ; CONSTANT: ReplayPointer 2
: AsyncKeyboard 3 ; CONSTANT: AsyncKeyboard 3
: SyncKeyboard 4 ; CONSTANT: SyncKeyboard 4
: ReplayKeyboard 5 ; CONSTANT: ReplayKeyboard 5
: AsyncBoth 6 ; CONSTANT: AsyncBoth 6
: SyncBoth 7 ; CONSTANT: SyncBoth 7
! Used in SetInputFocus, GetInputFocus ! Used in SetInputFocus, GetInputFocus
: RevertToNone ( -- n ) None ; : RevertToNone ( -- n ) None ;
: RevertToPointerRoot ( -- n ) PointerRoot ; : RevertToPointerRoot ( -- n ) PointerRoot ;
: RevertToParent 2 ; CONSTANT: RevertToParent 2
! ***************************************************************** ! *****************************************************************
! * ERROR CODES ! * ERROR CODES
! ***************************************************************** ! *****************************************************************
: Success 0 ; ! everything's okay CONSTANT: Success 0 ! everything's okay
: BadRequest 1 ; ! bad request code CONSTANT: BadRequest 1 ! bad request code
: BadValue 2 ; ! int parameter out of range CONSTANT: BadValue 2 ! int parameter out of range
: BadWindow 3 ; ! parameter not a Window CONSTANT: BadWindow 3 ! parameter not a Window
: BadPixmap 4 ; ! parameter not a Pixmap CONSTANT: BadPixmap 4 ! parameter not a Pixmap
: BadAtom 5 ; ! parameter not an Atom CONSTANT: BadAtom 5 ! parameter not an Atom
: BadCursor 6 ; ! parameter not a Cursor CONSTANT: BadCursor 6 ! parameter not a Cursor
: BadFont 7 ; ! parameter not a Font CONSTANT: BadFont 7 ! parameter not a Font
: BadMatch 8 ; ! parameter mismatch CONSTANT: BadMatch 8 ! parameter mismatch
: BadDrawable 9 ; ! parameter not a Pixmap or Window CONSTANT: BadDrawable 9 ! parameter not a Pixmap or Window
: BadAccess 10 ; ! depending on context: CONSTANT: BadAccess 10 ! depending on context:
! - key/button already grabbed ! - key/button already grabbed
! - attempt to free an illegal ! - attempt to free an illegal
! cmap entry ! cmap entry
@ -154,16 +154,16 @@ TYPEDEF: uchar KeyCode
! color map entry. ! color map entry.
! - attempt to modify the access control ! - attempt to modify the access control
! list from other than the local host. ! list from other than the local host.
: BadAlloc 11 ; ! insufficient resources CONSTANT: BadAlloc 11 ! insufficient resources
: BadColor 12 ; ! no such colormap CONSTANT: BadColor 12 ! no such colormap
: BadGC 13 ; ! parameter not a GC CONSTANT: BadGC 13 ! parameter not a GC
: BadIDChoice 14 ; ! choice not in range or already used CONSTANT: BadIDChoice 14 ! choice not in range or already used
: BadName 15 ; ! font or color name doesn't exist CONSTANT: BadName 15 ! font or color name doesn't exist
: BadLength 16 ; ! Request length incorrect CONSTANT: BadLength 16 ! Request length incorrect
: BadImplementation 17 ; ! server is defective CONSTANT: BadImplementation 17 ! server is defective
: FirstExtensionError 128 ; CONSTANT: FirstExtensionError 128
: LastExtensionError 255 ; CONSTANT: LastExtensionError 255
! ***************************************************************** ! *****************************************************************
! * WINDOW DEFINITIONS ! * WINDOW DEFINITIONS
@ -172,44 +172,44 @@ TYPEDEF: uchar KeyCode
! Window classes used by CreateWindow ! Window classes used by CreateWindow
! Note that CopyFromParent is already defined as 0 above ! Note that CopyFromParent is already defined as 0 above
: InputOutput 1 ; CONSTANT: InputOutput 1
: InputOnly 2 ; CONSTANT: InputOnly 2
! Used in CreateWindow for backing-store hint ! Used in CreateWindow for backing-store hint
: NotUseful 0 ; CONSTANT: NotUseful 0
: WhenMapped 1 ; CONSTANT: WhenMapped 1
: Always 2 ; CONSTANT: Always 2
! Used in ChangeSaveSet ! Used in ChangeSaveSet
: SetModeInsert 0 ; CONSTANT: SetModeInsert 0
: SetModeDelete 1 ; CONSTANT: SetModeDelete 1
! Used in ChangeCloseDownMode ! Used in ChangeCloseDownMode
: DestroyAll 0 ; CONSTANT: DestroyAll 0
: RetainPermanent 1 ; CONSTANT: RetainPermanent 1
: RetainTemporary 2 ; CONSTANT: RetainTemporary 2
! Window stacking method (in configureWindow) ! Window stacking method (in configureWindow)
: Above 0 ; CONSTANT: Above 0
: Below 1 ; CONSTANT: Below 1
: TopIf 2 ; CONSTANT: TopIf 2
: BottomIf 3 ; CONSTANT: BottomIf 3
: Opposite 4 ; CONSTANT: Opposite 4
! Circulation direction ! Circulation direction
: RaiseLowest 0 ; CONSTANT: RaiseLowest 0
: LowerHighest 1 ; CONSTANT: LowerHighest 1
! Property modes ! Property modes
: PropModeReplace 0 ; CONSTANT: PropModeReplace 0
: PropModePrepend 1 ; CONSTANT: PropModePrepend 1
: PropModeAppend 2 ; CONSTANT: PropModeAppend 2
! ***************************************************************** ! *****************************************************************
! * GRAPHICS DEFINITIONS ! * GRAPHICS DEFINITIONS
@ -217,62 +217,62 @@ TYPEDEF: uchar KeyCode
! LineStyle ! LineStyle
: LineSolid 0 ; CONSTANT: LineSolid 0
: LineOnOffDash 1 ; CONSTANT: LineOnOffDash 1
: LineDoubleDash 2 ; CONSTANT: LineDoubleDash 2
! capStyle ! capStyle
: CapNotLast 0 ; CONSTANT: CapNotLast 0
: CapButt 1 ; CONSTANT: CapButt 1
: CapRound 2 ; CONSTANT: CapRound 2
: CapProjecting 3 ; CONSTANT: CapProjecting 3
! joinStyle ! joinStyle
: JoinMiter 0 ; CONSTANT: JoinMiter 0
: JoinRound 1 ; CONSTANT: JoinRound 1
: JoinBevel 2 ; CONSTANT: JoinBevel 2
! fillStyle ! fillStyle
: FillSolid 0 ; CONSTANT: FillSolid 0
: FillTiled 1 ; CONSTANT: FillTiled 1
: FillStippled 2 ; CONSTANT: FillStippled 2
: FillOpaqueStippled 3 ; CONSTANT: FillOpaqueStippled 3
! fillRule ! fillRule
: EvenOddRule 0 ; CONSTANT: EvenOddRule 0
: WindingRule 1 ; CONSTANT: WindingRule 1
! subwindow mode ! subwindow mode
: ClipByChildren 0 ; CONSTANT: ClipByChildren 0
: IncludeInferiors 1 ; CONSTANT: IncludeInferiors 1
! SetClipRectangles ordering ! SetClipRectangles ordering
: Unsorted 0 ; CONSTANT: Unsorted 0
: YSorted 1 ; CONSTANT: YSorted 1
: YXSorted 2 ; CONSTANT: YXSorted 2
: YXBanded 3 ; CONSTANT: YXBanded 3
! CoordinateMode for drawing routines ! CoordinateMode for drawing routines
: CoordModeOrigin 0 ; ! relative to the origin CONSTANT: CoordModeOrigin 0 ! relative to the origin
: CoordModePrevious 1 ; ! relative to previous point CONSTANT: CoordModePrevious 1 ! relative to previous point
! Polygon shapes ! Polygon shapes
: Complex 0 ; ! paths may intersect CONSTANT: Complex 0 ! paths may intersect
: Nonconvex 1 ; ! no paths intersect, but not convex CONSTANT: Nonconvex 1 ! no paths intersect, but not convex
: Convex 2 ; ! wholly convex CONSTANT: Convex 2 ! wholly convex
! Arc modes for PolyFillArc ! Arc modes for PolyFillArc
: ArcChord 0 ; ! join endpoints of arc CONSTANT: ArcChord 0 ! join endpoints of arc
: ArcPieSlice 1 ; ! join endpoints to center of arc CONSTANT: ArcPieSlice 1 ! join endpoints to center of arc
! ***************************************************************** ! *****************************************************************
! * FONTS ! * FONTS
@ -280,10 +280,10 @@ TYPEDEF: uchar KeyCode
! used in QueryFont -- draw direction ! used in QueryFont -- draw direction
: FontLeftToRight 0 ; CONSTANT: FontLeftToRight 0
: FontRightToLeft 1 ; CONSTANT: FontRightToLeft 1
: FontChange 255 ; CONSTANT: FontChange 255
! ***************************************************************** ! *****************************************************************
! * IMAGING ! * IMAGING
@ -291,9 +291,9 @@ TYPEDEF: uchar KeyCode
! ImageFormat -- PutImage, GetImage ! ImageFormat -- PutImage, GetImage
: XYBitmap 0 ; ! depth 1, XYFormat CONSTANT: XYBitmap 0 ! depth 1, XYFormat
: XYPixmap 1 ; ! depth == drawable depth CONSTANT: XYPixmap 1 ! depth == drawable depth
: ZPixmap 2 ; ! depth == drawable depth CONSTANT: ZPixmap 2 ! depth == drawable depth
! ***************************************************************** ! *****************************************************************
! * COLOR MAP STUFF ! * COLOR MAP STUFF
@ -301,8 +301,8 @@ TYPEDEF: uchar KeyCode
! For CreateColormap ! For CreateColormap
: AllocNone 0 ; ! create map with no entries CONSTANT: AllocNone 0 ! create map with no entries
: AllocAll 1 ; ! allocate entire map writeable CONSTANT: AllocAll 1 ! allocate entire map writeable
! Flags used in StoreNamedColor, StoreColors ! Flags used in StoreNamedColor, StoreColors
@ -317,20 +317,20 @@ TYPEDEF: uchar KeyCode
! QueryBestSize Class ! QueryBestSize Class
: CursorShape 0 ; ! largest size that can be displayed CONSTANT: CursorShape 0 ! largest size that can be displayed
: TileShape 1 ; ! size tiled fastest CONSTANT: TileShape 1 ! size tiled fastest
: StippleShape 2 ; ! size stippled fastest CONSTANT: StippleShape 2 ! size stippled fastest
! ***************************************************************** ! *****************************************************************
! * KEYBOARD/POINTER STUFF ! * KEYBOARD/POINTER STUFF
! ***************************************************************** ! *****************************************************************
: AutoRepeatModeOff 0 ; CONSTANT: AutoRepeatModeOff 0
: AutoRepeatModeOn 1 ; CONSTANT: AutoRepeatModeOn 1
: AutoRepeatModeDefault 2 ; CONSTANT: AutoRepeatModeDefault 2
: LedModeOff 0 ; CONSTANT: LedModeOff 0
: LedModeOn 1 ; CONSTANT: LedModeOn 1
! masks for ChangeKeyboardControl ! masks for ChangeKeyboardControl
@ -343,33 +343,33 @@ TYPEDEF: uchar KeyCode
: KBKey ( -- n ) 6 2^ ; : KBKey ( -- n ) 6 2^ ;
: KBAutoRepeatMode ( -- n ) 7 2^ ; : KBAutoRepeatMode ( -- n ) 7 2^ ;
: MappingSuccess 0 ; CONSTANT: MappingSuccess 0
: MappingBusy 1 ; CONSTANT: MappingBusy 1
: MappingFailed 2 ; CONSTANT: MappingFailed 2
: MappingModifier 0 ; CONSTANT: MappingModifier 0
: MappingKeyboard 1 ; CONSTANT: MappingKeyboard 1
: MappingPointer 2 ; CONSTANT: MappingPointer 2
! ***************************************************************** ! *****************************************************************
! * SCREEN SAVER STUFF ! * SCREEN SAVER STUFF
! ***************************************************************** ! *****************************************************************
: DontPreferBlanking 0 ; CONSTANT: DontPreferBlanking 0
: PreferBlanking 1 ; CONSTANT: PreferBlanking 1
: DefaultBlanking 2 ; CONSTANT: DefaultBlanking 2
: DisableScreenSaver 0 ; CONSTANT: DisableScreenSaver 0
: DisableScreenInterval 0 ; CONSTANT: DisableScreenInterval 0
: DontAllowExposures 0 ; CONSTANT: DontAllowExposures 0
: AllowExposures 1 ; CONSTANT: AllowExposures 1
: DefaultExposures 2 ; CONSTANT: DefaultExposures 2
! for ForceScreenSaver ! for ForceScreenSaver
: ScreenSaverReset 0 ; CONSTANT: ScreenSaverReset 0
: ScreenSaverActive 1 ; CONSTANT: ScreenSaverActive 1
! ***************************************************************** ! *****************************************************************
! * HOSTS AND CONNECTIONS ! * HOSTS AND CONNECTIONS
@ -377,30 +377,30 @@ TYPEDEF: uchar KeyCode
! for ChangeHosts ! for ChangeHosts
: HostInsert 0 ; CONSTANT: HostInsert 0
: HostDelete 1 ; CONSTANT: HostDelete 1
! for ChangeAccessControl ! for ChangeAccessControl
: EnableAccess 1 ; CONSTANT: EnableAccess 1
: DisableAccess 0 ; CONSTANT: DisableAccess 0
! Display classes used in opening the connection ! Display classes used in opening the connection
! Note that the statically allocated ones are even numbered and the ! Note that the statically allocated ones are even numbered and the
! dynamically changeable ones are odd numbered ! dynamically changeable ones are odd numbered
: StaticGray 0 ; CONSTANT: StaticGray 0
: GrayScale 1 ; CONSTANT: GrayScale 1
: StaticColor 2 ; CONSTANT: StaticColor 2
: PseudoColor 3 ; CONSTANT: PseudoColor 3
: TrueColor 4 ; CONSTANT: TrueColor 4
: DirectColor 5 ; CONSTANT: DirectColor 5
! Byte order used in imageByteOrder and bitmapBitOrder ! Byte order used in imageByteOrder and bitmapBitOrder
: LSBFirst 0 ; CONSTANT: LSBFirst 0
: MSBFirst 1 ; CONSTANT: MSBFirst 1
! ***************************************************************** ! *****************************************************************
! * EXTENDED WINDOW MANAGER HINTS ! * EXTENDED WINDOW MANAGER HINTS

34
basis/x11/glx/glx.factor
View File

@ -9,23 +9,23 @@ IN: x11.glx
LIBRARY: glx LIBRARY: glx
! Visual Config Attributes (glXGetConfig, glXGetFBConfigAttrib) ! Visual Config Attributes (glXGetConfig, glXGetFBConfigAttrib)
: GLX_USE_GL 1 ; ! support GLX rendering CONSTANT: GLX_USE_GL 1 ! support GLX rendering
: GLX_BUFFER_SIZE 2 ; ! depth of the color buffer CONSTANT: GLX_BUFFER_SIZE 2 ! depth of the color buffer
: GLX_LEVEL 3 ; ! level in plane stacking CONSTANT: GLX_LEVEL 3 ! level in plane stacking
: GLX_RGBA 4 ; ! true if RGBA mode CONSTANT: GLX_RGBA 4 ! true if RGBA mode
: GLX_DOUBLEBUFFER 5 ; ! double buffering supported CONSTANT: GLX_DOUBLEBUFFER 5 ! double buffering supported
: GLX_STEREO 6 ; ! stereo buffering supported CONSTANT: GLX_STEREO 6 ! stereo buffering supported
: GLX_AUX_BUFFERS 7 ; ! number of aux buffers CONSTANT: GLX_AUX_BUFFERS 7 ! number of aux buffers
: GLX_RED_SIZE 8 ; ! number of red component bits CONSTANT: GLX_RED_SIZE 8 ! number of red component bits
: GLX_GREEN_SIZE 9 ; ! number of green component bits CONSTANT: GLX_GREEN_SIZE 9 ! number of green component bits
: GLX_BLUE_SIZE 10 ; ! number of blue component bits CONSTANT: GLX_BLUE_SIZE 10 ! number of blue component bits
: GLX_ALPHA_SIZE 11 ; ! number of alpha component bits CONSTANT: GLX_ALPHA_SIZE 11 ! number of alpha component bits
: GLX_DEPTH_SIZE 12 ; ! number of depth bits CONSTANT: GLX_DEPTH_SIZE 12 ! number of depth bits
: GLX_STENCIL_SIZE 13 ; ! number of stencil bits CONSTANT: GLX_STENCIL_SIZE 13 ! number of stencil bits
: GLX_ACCUM_RED_SIZE 14 ; ! number of red accum bits CONSTANT: GLX_ACCUM_RED_SIZE 14 ! number of red accum bits
: GLX_ACCUM_GREEN_SIZE 15 ; ! number of green accum bits CONSTANT: GLX_ACCUM_GREEN_SIZE 15 ! number of green accum bits
: GLX_ACCUM_BLUE_SIZE 16 ; ! number of blue accum bits CONSTANT: GLX_ACCUM_BLUE_SIZE 16 ! number of blue accum bits
: GLX_ACCUM_ALPHA_SIZE 17 ; ! number of alpha accum bits CONSTANT: GLX_ACCUM_ALPHA_SIZE 17 ! number of alpha accum bits
TYPEDEF: XID GLXContextID TYPEDEF: XID GLXContextID
TYPEDEF: XID GLXPixmap TYPEDEF: XID GLXPixmap

2
basis/x11/xim/xim.factor
View File

@ -34,7 +34,7 @@ SYMBOL: xim
XNResourceClass over 0 XCreateIC XNResourceClass over 0 XCreateIC
[ "XCreateIC() failed" throw ] unless* ; [ "XCreateIC() failed" throw ] unless* ;
: buf-size 100 ; CONSTANT: buf-size 100
SYMBOL: keybuf SYMBOL: keybuf
SYMBOL: keysym SYMBOL: keysym

12
basis/xml/entities/entities.factor
View File

@ -4,20 +4,20 @@ USING: namespaces make kernel assocs sequences fry values
io.files io.encodings.binary xml.state ; io.files io.encodings.binary xml.state ;
IN: xml.entities IN: xml.entities
: entities-out CONSTANT: entities-out
H{ H{
{ CHAR: < "&lt;" } { CHAR: < "&lt;" }
{ CHAR: > "&gt;" } { CHAR: > "&gt;" }
{ CHAR: & "&amp;" } { CHAR: & "&amp;" }
} ; }
: quoted-entities-out CONSTANT: quoted-entities-out
H{ H{
{ CHAR: & "&amp;" } { CHAR: & "&amp;" }
{ CHAR: ' "&apos;" } { CHAR: ' "&apos;" }
{ CHAR: " "&quot;" } { CHAR: " "&quot;" }
{ CHAR: < "&lt;" } { CHAR: < "&lt;" }
} ; }
: escape-string-by ( str table -- escaped ) : escape-string-by ( str table -- escaped )
#! Convert <, >, &, ' and " to HTML entities. #! Convert <, >, &, ' and " to HTML entities.
@ -29,14 +29,14 @@ IN: xml.entities
: escape-quoted-string ( str -- newstr ) : escape-quoted-string ( str -- newstr )
quoted-entities-out escape-string-by ; quoted-entities-out escape-string-by ;
: entities CONSTANT: entities
H{ H{
{ "lt" CHAR: < } { "lt" CHAR: < }
{ "gt" CHAR: > } { "gt" CHAR: > }
{ "amp" CHAR: & } { "amp" CHAR: & }
{ "apos" CHAR: ' } { "apos" CHAR: ' }
{ "quot" CHAR: " } { "quot" CHAR: " }
} ; }
: with-entities ( entities quot -- ) : with-entities ( entities quot -- )
[ swap extra-entities set call ] with-scope ; inline [ swap extra-entities set call ] with-scope ; inline

4
basis/xml/errors/errors.factor
View File

@ -290,7 +290,7 @@ M: quoteless-attr summary
TUPLE: attr-w/< < xml-error-at ; TUPLE: attr-w/< < xml-error-at ;
: attr-w/< ( value -- * ) : attr-w/< ( -- * )
\ attr-w/< xml-error-at throw ; \ attr-w/< xml-error-at throw ;
M: attr-w/< summary M: attr-w/< summary
@ -299,7 +299,7 @@ M: attr-w/< summary
TUPLE: text-w/]]> < xml-error-at ; TUPLE: text-w/]]> < xml-error-at ;
: text-w/]]> ( text -- * ) : text-w/]]> ( -- * )
\ text-w/]]> xml-error-at throw ; \ text-w/]]> xml-error-at throw ;
M: text-w/]]> summary M: text-w/]]> summary

2
core/bootstrap/primitives.factor
View File

@ -538,4 +538,4 @@ tuple
[ [ first2 ] dip make-primitive ] each-index [ [ first2 ] dip make-primitive ] each-index
! Bump build number ! Bump build number
"build" "kernel" create build 1+ 1quotation define "build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared

4
core/compiler/units/units-docs.factor
View File

@ -67,7 +67,3 @@ HELP: modify-code-heap ( alist -- )
HELP: compile HELP: compile
{ $values { "words" "a sequence of words" } } { $values { "words" "a sequence of words" } }
{ $description "Compiles a set of words." } ; { $description "Compiles a set of words." } ;
HELP: compile-call
{ $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." } ;

3
core/compiler/units/units.factor
View File

@ -172,9 +172,6 @@ SYMBOL: remake-generics-hook
] [ ] cleanup ] [ ] cleanup
] with-scope ; inline ] with-scope ; inline
: compile-call ( quot -- )
[ define-temp ] with-compilation-unit execute ;
: default-recompile-hook ( words -- alist ) : default-recompile-hook ( words -- alist )
[ f ] { } map>assoc ; [ f ] { } map>assoc ;

8
core/continuations/continuations.factor
View File

@ -92,10 +92,10 @@ C: <continuation> continuation
PRIVATE> PRIVATE>
: continue-with ( obj continuation -- ) : continue-with ( obj continuation -- * )
[ (continue-with) ] 2 (throw) ; [ (continue-with) ] 2 (throw) ;
: continue ( continuation -- ) : continue ( continuation -- * )
f swap continue-with ; f swap continue-with ;
SYMBOL: return-continuation SYMBOL: return-continuation
@ -103,7 +103,7 @@ SYMBOL: return-continuation
: with-return ( quot -- ) : with-return ( quot -- )
[ [ return-continuation set ] prepose callcc0 ] with-scope ; inline [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
: return ( -- ) : return ( -- * )
return-continuation get continue ; return-continuation get continue ;
: with-datastack ( stack quot -- newstack ) : with-datastack ( stack quot -- newstack )
@ -173,7 +173,7 @@ TUPLE: restart name obj continuation ;
C: <restart> restart C: <restart> restart
: restart ( restart -- ) : restart ( restart -- * )
[ obj>> ] [ continuation>> ] bi continue-with ; [ obj>> ] [ continuation>> ] bi continue-with ;
M: object compute-restarts drop { } ; M: object compute-restarts drop { } ;

6
core/effects/effects.factor
View File

@ -45,9 +45,9 @@ M: effect effect>string ( effect -- string )
GENERIC: stack-effect ( word -- effect/f ) GENERIC: stack-effect ( word -- effect/f )
M: word stack-effect M: word stack-effect "declared-effect" word-prop ;
"declared-effect" "inferred-effect"
[ word-prop ] bi-curry@ bi or ; M: deferred stack-effect call-next-method (( -- * )) or ;
M: effect clone M: effect clone
[ in>> clone ] [ out>> clone ] bi <effect> ; [ in>> clone ] [ out>> clone ] bi <effect> ;

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

@ -50,16 +50,16 @@ ERROR: no-method object generic ;
convert-hi-tag-methods convert-hi-tag-methods
<lo-tag-dispatch-engine> ; <lo-tag-dispatch-engine> ;
: mangle-method ( method -- quot )
1quotation generic get extra-values \ drop <repetition>
prepend [ ] like ;
: find-default ( methods -- quot ) : find-default ( methods -- quot )
#! Side-effects methods. #! Side-effects methods.
object bootstrap-word swap delete-at* [ object bootstrap-word swap delete-at* [
drop generic get "default-method" word-prop 1quotation drop generic get "default-method" word-prop mangle-method
] unless ; ] unless ;
: mangle-method ( method generic -- quot )
[ 1quotation ] [ extra-values \ drop <repetition> ] bi*
prepend [ ] like ;
: <standard-engine> ( word -- engine ) : <standard-engine> ( word -- engine )
object bootstrap-word assumed set { object bootstrap-word assumed set {
[ generic set ] [ generic set ]
@ -67,7 +67,7 @@ ERROR: no-method object generic ;
[ V{ } clone "engines" set-word-prop ] [ V{ } clone "engines" set-word-prop ]
[ [
"methods" word-prop "methods" word-prop
[ generic get mangle-method ] assoc-map [ mangle-method ] assoc-map
[ find-default default set ] [ find-default default set ]
[ <big-dispatch-engine> ] [ <big-dispatch-engine> ]
bi bi

5
core/io/encodings/encodings-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io quotations ; USING: help.markup help.syntax io quotations math ;
IN: io.encodings IN: io.encodings
HELP: <encoder> HELP: <encoder>
@ -71,6 +71,9 @@ HELP: with-encoded-output
{ $description "Creates a new encoder with the given encoding descriptor and calls the quotation using this encoder. The original encoder object is restored after the quotation returns and the stream is kept open for future output operations." } ; { $description "Creates a new encoder with the given encoding descriptor and calls the quotation using this encoder. The original encoder object is restored after the quotation returns and the stream is kept open for future output operations." } ;
HELP: replacement-char HELP: replacement-char
{ $values
{ "value" integer }
}
{ $description "A code point that replaces input that could not be decoded. The presence of this character in the decoded data usually signifies an error." } ; { $description "A code point that replaces input that could not be decoded. The presence of this character in the decoded data usually signifies an error." } ;
ARTICLE: "encodings-descriptors" "Encoding descriptors" ARTICLE: "encodings-descriptors" "Encoding descriptors"

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

@ -288,12 +288,12 @@ HELP: define-declared
{ $side-effects "word" } ; { $side-effects "word" } ;
HELP: define-temp HELP: define-temp
{ $values { "quot" quotation } { "word" word } } { $values { "quot" quotation } { "effect" effect } { "word" word } }
{ $description "Creates an uninterned word that will call " { $snippet "quot" } " when executed." } { $description "Creates an uninterned word that will call " { $snippet "quot" } " when executed." }
{ $notes { $notes
"The following phrases are equivalent:" "The following phrases are equivalent:"
{ $code "[ 2 2 + . ] call" } { $code "[ 2 2 + . ] call" }
{ $code "[ 2 2 + . ] define-temp execute" } { $code "[ 2 2 + . ] (( -- )) define-temp execute" }
"This word must be called from inside " { $link with-compilation-unit } "." "This word must be called from inside " { $link with-compilation-unit } "."
} ; } ;

4
core/words/words.factor
View File

@ -211,8 +211,8 @@ M: word subwords drop f ;
: gensym ( -- word ) : gensym ( -- word )
"( gensym )" f <word> ; "( gensym )" f <word> ;
: define-temp ( quot -- word ) : define-temp ( quot effect -- word )
[ gensym dup ] dip define ; [ gensym dup ] 2dip define-declared ;
: reveal ( word -- ) : reveal ( word -- )
dup [ name>> ] [ vocabulary>> ] bi dup vocab-words dup [ name>> ] [ vocabulary>> ] bi dup vocab-words

2
extra/24-game/24-game.factor
View File

@ -7,7 +7,7 @@ arrays words quotations accessors math.parser backtrack assocs ;
IN: 24-game IN: 24-game
SYMBOL: commands SYMBOL: commands
: nop ; : nop ( -- ) ;
: do-something ( a b -- c ) { + - * } amb-execute ; : do-something ( a b -- c ) { + - * } amb-execute ;
: maybe-swap ( a b -- a b ) { nop swap } amb-execute ; : maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
: some-rots ( a b c -- a b c ) : some-rots ( a b c -- a b c )

4
extra/benchmark/backtrack/backtrack.factor
View File

@ -10,7 +10,7 @@ IN: benchmark.backtrack
! placing them on the stack, and applying the operations ! placing them on the stack, and applying the operations
! +, -, * and rot as many times as we wish. ! +, -, * and rot as many times as we wish.
: nop ; : nop ( -- ) ;
: do-something ( a b -- c ) : do-something ( a b -- c )
{ + - * } amb-execute ; { + - * } amb-execute ;
@ -42,7 +42,7 @@ MEMO: 24-from-4 ( a b c d -- ? )
] sigma ] sigma
] sigma ; ] sigma ;
: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ; CONSTANT: words { 24-from-1 24-from-2 24-from-3 24-from-4 }
: backtrack-benchmark ( -- ) : backtrack-benchmark ( -- )
words [ reset-memoized ] each words [ reset-memoized ] each

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

@ -10,8 +10,6 @@ CONSTANT: IC 29573
CONSTANT: initial-seed 42 CONSTANT: initial-seed 42
CONSTANT: line-length 60 CONSTANT: line-length 60
USE: math.private
: random ( seed -- n seed ) : random ( seed -- n seed )
>float IA * IC + IM mod [ IM /f ] keep ; inline >float IA * IC + IM mod [ IM /f ] keep ; inline
@ -19,7 +17,7 @@ HINTS: random fixnum ;
CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA" CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"
: IUB CONSTANT: IUB
{ {
{ CHAR: a 0.27 } { CHAR: a 0.27 }
{ CHAR: c 0.12 } { CHAR: c 0.12 }
@ -37,15 +35,15 @@ CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC
{ CHAR: V 0.02 } { CHAR: V 0.02 }
{ CHAR: W 0.02 } { CHAR: W 0.02 }
{ CHAR: Y 0.02 } { CHAR: Y 0.02 }
} ; inline }
: homo-sapiens CONSTANT: homo-sapiens
{ {
{ CHAR: a 0.3029549426680 } { CHAR: a 0.3029549426680 }
{ CHAR: c 0.1979883004921 } { CHAR: c 0.1979883004921 }
{ CHAR: g 0.1975473066391 } { CHAR: g 0.1975473066391 }
{ CHAR: t 0.3015094502008 } { CHAR: t 0.3015094502008 }
} ; inline }
: make-cumulative ( freq -- chars floats ) : make-cumulative ( freq -- chars floats )
dup keys >byte-array dup keys >byte-array

7
extra/benchmark/raytracer/raytracer.factor
View File

@ -8,13 +8,14 @@ hints ;
IN: benchmark.raytracer IN: benchmark.raytracer
! parameters ! parameters
: light
#! Normalized { -1 -3 2 }. ! Normalized { -1 -3 2 }.
CONSTANT: light
double-array{ double-array{
-0.2672612419124244 -0.2672612419124244
-0.8017837257372732 -0.8017837257372732
0.5345224838248488 0.5345224838248488
} ; inline }
CONSTANT: oversampling 4 CONSTANT: oversampling 4

2
extra/benchmark/sockets/sockets.factor
View File

@ -10,7 +10,7 @@ SYMBOL: counter
SYMBOL: port-promise SYMBOL: port-promise
SYMBOL: server SYMBOL: server
: number-of-requests 1000 ; CONSTANT: number-of-requests 1000
: server-addr ( -- addr ) : server-addr ( -- addr )
"127.0.0.1" port-promise get ?promise <inet4> ; "127.0.0.1" port-promise get ?promise <inet4> ;

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

@ -6,68 +6,80 @@
! http://cairographics.org/samples/text/ ! http://cairographics.org/samples/text/
USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render USING: cairo.ffi math math.constants byte-arrays kernel ui
ui.gadgets opengl.gl accessors ; ui.render combinators ui.gadgets opengl.gl accessors
namespaces opengl ;
IN: cairo-demo IN: cairo-demo
: make-image-array ( -- array ) : make-image-array ( -- array )
384 256 4 * * <byte-array> ; 384 256 4 * * <byte-array> ;
: convert-array-to-surface ( array -- cairo_surface_t ) : convert-array-to-surface ( array -- cairo_surface_t )
CAIRO_FORMAT_ARGB32 384 256 over 4 * CAIRO_FORMAT_ARGB32 384 256 over 4 *
cairo_image_surface_create_for_data ; cairo_image_surface_create_for_data ;
TUPLE: cairo-demo-gadget < gadget image-array cairo-t ; TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
M: cairo-demo-gadget draw-gadget* ( gadget -- ) M: cairo-demo-gadget draw-gadget* ( gadget -- )
0 0 glRasterPos2i origin get [
1.0 -1.0 glPixelZoom 0 0 glRasterPos2i
[ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip 1.0 -1.0 glPixelZoom
image-array>> glDrawPixels ; [ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip
image-array>> glDrawPixels
] with-translation ;
: create-surface ( gadget -- cairo_surface_t ) : create-surface ( gadget -- cairo_surface_t )
make-image-array [ swap (>>image-array) ] keep make-image-array [ swap (>>image-array) ] keep
convert-array-to-surface ; convert-array-to-surface ;
: init-cairo ( gadget -- cairo_t ) : init-cairo ( gadget -- cairo_t )
create-surface cairo_create ; create-surface cairo_create ;
M: cairo-demo-gadget pref-dim* drop { 384 256 0 } ; M: cairo-demo-gadget pref-dim* drop { 384 256 } ;
ERROR: no-cairo-t ;
<PRIVATE
: draw-hello-world ( gadget -- ) : draw-hello-world ( gadget -- )
cairo-t>> cairo-t>> [ no-cairo-t ] unless*
dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face {
dup 90.0 cairo_set_font_size [
dup 10.0 135.0 cairo_move_to "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
dup "Hello" cairo_show_text cairo_select_font_face
dup 70.0 165.0 cairo_move_to ]
dup "World" cairo_text_path [ 90.0 cairo_set_font_size ]
dup 0.5 0.5 1 cairo_set_source_rgb [ 10.0 135.0 cairo_move_to ]
dup cairo_fill_preserve [ "Hello" cairo_show_text ]
dup 0 0 0 cairo_set_source_rgb [ 70.0 165.0 cairo_move_to ]
dup 2.56 cairo_set_line_width [ "World" cairo_text_path ]
dup cairo_stroke [ 0.5 0.5 1 cairo_set_source_rgb ]
dup 1 0.2 0.2 0.6 cairo_set_source_rgba [ cairo_fill_preserve ]
dup 10.0 135.0 5.12 0 pi 2 * cairo_arc [ 0 0 0 cairo_set_source_rgb ]
dup cairo_close_path [ 2.56 cairo_set_line_width ]
dup 70.0 165.0 5.12 0 pi 2 * cairo_arc [ cairo_stroke ]
cairo_fill ; [ 1 0.2 0.2 0.6 cairo_set_source_rgba ]
[ 10.0 135.0 5.12 0 pi 2 * cairo_arc ]
[ cairo_close_path ]
[ 70.0 165.0 5.12 0 pi 2 * cairo_arc ]
[ cairo_fill ]
} cleave ;
PRIVATE>
M: cairo-demo-gadget graft* ( gadget -- ) M: cairo-demo-gadget graft* ( gadget -- )
dup dup init-cairo swap (>>cairo-t) draw-hello-world ; dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
M: cairo-demo-gadget ungraft* ( gadget -- ) M: cairo-demo-gadget ungraft* ( gadget -- )
cairo-t>> cairo_destroy ; cairo-t>> cairo_destroy ;
: <cairo-demo-gadget> ( -- gadget ) : <cairo-demo-gadget> ( -- gadget )
cairo-demo-gadget new-gadget ; cairo-demo-gadget new-gadget ;
: run ( -- ) : run ( -- )
[ [
<cairo-demo-gadget> "Hello World from Factor!" open-window <cairo-demo-gadget> "Hello World from Factor!" open-window
] with-ui ; ] with-ui ;
MAIN: run MAIN: run

4
extra/galois-talk/galois-talk.factor
View File

@ -8,7 +8,7 @@ help.topics math.functions compiler.tree.optimizer
compiler.cfg.optimizer fry ; compiler.cfg.optimizer fry ;
IN: galois-talk IN: galois-talk
: galois-slides CONSTANT: galois-slides
{ {
{ $slide "Factor!" { $slide "Factor!"
{ $url "http://factorcode.org" } { $url "http://factorcode.org" }
@ -305,7 +305,7 @@ IN: galois-talk
"Factor has many cool things that I didn't talk about" "Factor has many cool things that I didn't talk about"
"Questions?" "Questions?"
} }
} ; }
: galois-talk ( -- ) galois-slides slides-window ; : galois-talk ( -- ) galois-slides slides-window ;

4
extra/game-input/iokit/iokit.factor
View File

@ -121,12 +121,12 @@ CONSTANT: hat-switch-matching-hash
: hat-switch? ( {usage-page,usage} -- ? ) : hat-switch? ( {usage-page,usage} -- ? )
{ 1 HEX: 39 } = ; inline { 1 HEX: 39 } = ; inline
: pov-values CONSTANT: pov-values
{ {
pov-up pov-up-right pov-right pov-down-right pov-up pov-up-right pov-right pov-down-right
pov-down pov-down-left pov-left pov-up-left pov-down pov-down-left pov-left pov-up-left
pov-neutral pov-neutral
} ; inline }
: button-value ( value -- f/(0,1] ) : button-value ( value -- f/(0,1] )
IOHIDValueGetIntegerValue dup zero? [ drop f ] when ; IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;

4
extra/google-tech-talk/google-tech-talk.factor
View File

@ -8,7 +8,7 @@ help.topics math.functions compiler.tree.optimizer
compiler.cfg.optimizer fry ; compiler.cfg.optimizer fry ;
IN: google-tech-talk IN: google-tech-talk
: google-slides CONSTANT: google-slides
{ {
{ $slide "Factor!" { $slide "Factor!"
{ $url "http://factorcode.org" } { $url "http://factorcode.org" }
@ -562,7 +562,7 @@ IN: google-tech-talk
"Put your prejudices aside and give it a shot!" "Put your prejudices aside and give it a shot!"
} }
{ $slide "Questions?" } { $slide "Questions?" }
} ; }
: google-talk ( -- ) google-slides slides-window ; : google-talk ( -- ) google-slides slides-window ;

2
extra/irc/client/client.factor
View File

@ -12,7 +12,7 @@ IN: irc.client
! Setup and running objects ! Setup and running objects
! ====================================== ! ======================================
: irc-port 6667 ; ! Default irc port CONSTANT: irc-port 6667 ! Default irc port
TUPLE: irc-profile server port nickname password ; TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile C: <irc-profile> irc-profile

6
extra/irc/ui/ui.factor
View File

@ -28,9 +28,9 @@ TUPLE: irc-tab < frame chat client window ;
: write-color ( str color -- ) : write-color ( str color -- )
foreground associate format ; foreground associate format ;
: dark-red T{ rgba f 0.5 0.0 0.0 1 } ; CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }
: dark-green T{ rgba f 0.0 0.5 0.0 1 } ; CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }
: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ; CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }
: dot-or-parens ( string -- string ) : dot-or-parens ( string -- string )
[ "." ] [ "." ]

8
extra/joystick-demo/joystick-demo.factor
View File

@ -5,8 +5,8 @@ calendar locals strings ui.gadgets.buttons
combinators math.parser assocs threads ; combinators math.parser assocs threads ;
IN: joystick-demo IN: joystick-demo
: SIZE { 151 151 } ; CONSTANT: SIZE { 151 151 }
: INDICATOR-SIZE { 4 4 } ; CONSTANT: INDICATOR-SIZE { 4 4 }
: FREQUENCY ( -- f ) 30 recip seconds ; : FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: axis-gadget < gadget indicator z-indicator pov ; TUPLE: axis-gadget < gadget indicator z-indicator pov ;
@ -21,7 +21,7 @@ M: axis-gadget pref-dim* drop SIZE ;
: indicator-polygon ( -- polygon ) : indicator-polygon ( -- polygon )
{ 0 0 } INDICATOR-SIZE (rect-polygon) ; { 0 0 } INDICATOR-SIZE (rect-polygon) ;
: pov-polygons CONSTANT: pov-polygons
V{ V{
{ pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } } { pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } }
{ pov-up { { 70 65 } { 75 60 } { 80 65 } } } { pov-up { { 70 65 } { 75 60 } { 80 65 } } }
@ -32,7 +32,7 @@ M: axis-gadget pref-dim* drop SIZE ;
{ pov-down-left { { 67 90 } { 60 90 } { 60 83 } } } { pov-down-left { { 67 90 } { 60 90 } { 60 83 } } }
{ pov-left { { 65 70 } { 60 75 } { 65 80 } } } { pov-left { { 65 70 } { 60 75 } { 65 80 } } }
{ pov-up-left { { 67 60 } { 60 60 } { 60 67 } } } { pov-up-left { { 67 60 } { 60 60 } { 60 67 } } }
} ; }
: <indicator-gadget> ( color -- indicator ) : <indicator-gadget> ( color -- indicator )
indicator-polygon <polygon-gadget> ; indicator-polygon <polygon-gadget> ;

6
extra/key-caps/key-caps.factor
View File

@ -4,7 +4,7 @@ words arrays assocs math calendar fry alarms ui
ui.gadgets.borders ui.gestures ; ui.gadgets.borders ui.gestures ;
IN: key-caps IN: key-caps
: key-locations H{ CONSTANT: key-locations H{
{ key-escape { { 0 0 } { 10 10 } } } { key-escape { { 0 0 } { 10 10 } } }
{ key-f1 { { 20 0 } { 10 10 } } } { key-f1 { { 20 0 } { 10 10 } } }
@ -129,9 +129,9 @@ IN: key-caps
{ key-keypad-0 { { 190 55 } { 20 10 } } } { key-keypad-0 { { 190 55 } { 20 10 } } }
{ key-keypad-. { { 210 55 } { 10 10 } } } { key-keypad-. { { 210 55 } { 10 10 } } }
} ; }
: KEYBOARD-SIZE { 230 65 } ; CONSTANT: KEYBOARD-SIZE { 230 65 }
: FREQUENCY ( -- f ) 30 recip seconds ; : FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: key-caps-gadget < gadget keys alarm ; TUPLE: key-caps-gadget < gadget keys alarm ;

2
extra/lint/lint.factor
View File

@ -42,7 +42,7 @@ SYMBOL: def-hash-keys
set-alien-float alien-float set-alien-float alien-float
} ; } ;
: trivial-defs : trivial-defs ( -- seq )
{ {
[ drop ] [ 2array ] [ drop ] [ 2array ]
[ bitand ] [ bitand ]

2
extra/lisppaste/lisppaste.factor
View File

@ -1,7 +1,7 @@
USING: arrays kernel xml-rpc ; USING: arrays kernel xml-rpc ;
IN: lisppaste IN: lisppaste
: url "http://www.common-lisp.net:8185/RPC2" ; CONSTANT: url "http://www.common-lisp.net:8185/RPC2"
: channels ( -- seq ) : channels ( -- seq )
{ } "listchannels" url invoke-method ; { } "listchannels" url invoke-method ;

28
extra/mason/common/common.factor
View File

@ -67,24 +67,24 @@ SYMBOL: stamp
: ?prepare-build-machine ( -- ) : ?prepare-build-machine ( -- )
builds/factor exists? [ prepare-build-machine ] unless ; builds/factor exists? [ prepare-build-machine ] unless ;
: load-everything-vocabs-file "load-everything-vocabs" ; CONSTANT: load-everything-vocabs-file "load-everything-vocabs"
: load-everything-errors-file "load-everything-errors" ; CONSTANT: load-everything-errors-file "load-everything-errors"
: test-all-vocabs-file "test-all-vocabs" ; CONSTANT: test-all-vocabs-file "test-all-vocabs"
: test-all-errors-file "test-all-errors" ; CONSTANT: test-all-errors-file "test-all-errors"
: help-lint-vocabs-file "help-lint-vocabs" ; CONSTANT: help-lint-vocabs-file "help-lint-vocabs"
: help-lint-errors-file "help-lint-errors" ; CONSTANT: help-lint-errors-file "help-lint-errors"
: boot-time-file "boot-time" ; CONSTANT: boot-time-file "boot-time"
: load-time-file "load-time" ; CONSTANT: load-time-file "load-time"
: compiler-errors-file "compiler-errors" ; CONSTANT: compiler-errors-file "compiler-errors"
: test-time-file "test-time" ; CONSTANT: test-time-file "test-time"
: help-lint-time-file "help-lint-time" ; CONSTANT: help-lint-time-file "help-lint-time"
: benchmark-time-file "benchmark-time" ; CONSTANT: benchmark-time-file "benchmark-time"
: html-help-time-file "html-help-time" ; CONSTANT: html-help-time-file "html-help-time"
: benchmarks-file "benchmarks" ; CONSTANT: benchmarks-file "benchmarks"
SYMBOL: status SYMBOL: status

4
extra/math/analysis/analysis.factor
View File

@ -11,11 +11,11 @@ IN: math.analysis
CONSTANT: gamma-g6 5.15 CONSTANT: gamma-g6 5.15
: gamma-p6 CONSTANT: gamma-p6
{ {
2.50662827563479526904 225.525584619175212544 -268.295973841304927459 2.50662827563479526904 225.525584619175212544 -268.295973841304927459
80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556 80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556
} ; inline }
: gamma-z ( x n -- seq ) : gamma-z ( x n -- seq )
[ + recip ] with map 1.0 0 pick set-nth ; [ + recip ] with map 1.0 0 pick set-nth ;

2
extra/maze/maze.factor
View File

@ -4,7 +4,7 @@ arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
math.order math.rectangles ; math.order math.rectangles ;
IN: maze IN: maze
: line-width 8 ; CONSTANT: line-width 8
SYMBOL: visited SYMBOL: visited

4
extra/minneapolis-talk/minneapolis-talk.factor
View File

@ -2,7 +2,7 @@ USING: slides help.markup math arrays hashtables namespaces
sequences kernel sequences parser memoize ; sequences kernel sequences parser memoize ;
IN: minneapolis-talk IN: minneapolis-talk
: minneapolis-slides CONSTANT: minneapolis-slides
{ {
{ $slide "What is Factor?" { $slide "What is Factor?"
"Dynamically typed, stack language" "Dynamically typed, stack language"
@ -175,7 +175,7 @@ IN: minneapolis-talk
"Mailing list: factor-talk@lists.sf.net" "Mailing list: factor-talk@lists.sf.net"
} }
{ $slide "Questions?" } { $slide "Questions?" }
} ; }
: minneapolis-talk ( -- ) minneapolis-slides slides-window ; : minneapolis-talk ( -- ) minneapolis-slides slides-window ;

116
extra/minneapolis-talk/minneapolis-talk.txt
View File

@ -1,116 +0,0 @@
- how to create a small module
- editor integration
- presentations
- module system
- copy and paste factoring, inverse
- help system
- tetris
- memoization
- editing inspector demo
- dynamic scope, lexical scope
Factor: contradictions?
-----------------------
Have our cake and eat it too
Research -vs- practical
High level -vs- fast
Interactive -vs- deployment
Factor from 10,000 feet
-----------------------
word: named function
vocabulary: module
quotation: anonymous function
classes, objects, etc.
The stack
---------
- Stack -vs- applicative
- Pass by reference, dynamically typed
- Stack languages: you can omit names where they're not needed
- More compositional style
- If you need to name things for clarity, you can:
lexical vars, dynamic vars, sequences, assocs, objects...
Functional programming
----------------------
Quotations
Curry
Continuations
Object-oriented programming
---------------------------
Generic words: sort of like open classes
Tuple reshaping
Editing inspector
Meta programming
----------------
Simple, orthogonal core
Why use a stack at all?
-----------------------
Nice idioms: 10 days ago
Copy and paste factoring
Easy meta-programming
Sequence operations correspond to functional operations:
- curry is adding at the front
- compose is append
UI
--
Written in Factor
renders with OpenGL
Windows, X11, Cocoa backends
You can call Windows, X11, Cocoa APIs directly
OpenGL 2.1 shaders, OpenAL 3D audio...
Tools
-----
Edit
Usages
Profiler
Easy to make your own tools
Implementation
--------------
Two compilers
Generational garbage collector
Non-blocking I/O
Hands on
--------
Community
---------
Factor started in 2003
About a dozen contributors
Handful of "core contributors"
Web site: http://factorcode.org
IRC: #concatenative on irc.freenode.net
Mailing list: factor-talk@lists.sf.net
C library interface
-------------------
Efficient
No need to write C code
Supports floats, structs, unions, ...
Function pointers, callbacks
Here is an example
TerminateProcess
process-handle TerminateProcess

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