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

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

db4
Joe Groff 2009-02-28 15:01:50 -06:00
parent bb0e2a49ba 0214dc5e7d
commit 91652c706b
292 changed files with 3235 additions and 4914 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.
USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting
@ -275,7 +275,7 @@ M: long-long-type box-return ( type -- )
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
: primitive-types
CONSTANT: primitive-types
{
"char" "uchar"
"short" "ushort"
@ -284,7 +284,7 @@ M: long-long-type box-return ( type -- )
"longlong" "ulonglong"
"float" "double"
"void*" "bool"
} ;
}
[
<c-type>

4
basis/alien/fortran/fortran.factor
View File

@ -170,8 +170,8 @@ M: character-type (fortran-type>c-type)
: (parse-fortran-type) ( fortran-type-string -- type )
parse-out swap parse-dims swap parse-size swap
dup >lower fortran>c-types at*
[ nip new-fortran-type ] [ drop misc-type boa ] if ;
>lower fortran>c-types ?at
[ new-fortran-type ] [ misc-type boa ] if ;
: parse-fortran-type ( fortran-type-string/f -- type/f )
dup [ (parse-fortran-type) ] when ;

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 ;
IN: bootstrap.image.download
: url URL" http://factorcode.org/images/latest/" ;
CONSTANT: url URL" http://factorcode.org/images/latest/"
: download-checksums ( -- alist )
url "checksums.txt" >url derive-url http-get nip

20
basis/bootstrap/image/image.factor
View File

@ -77,20 +77,20 @@ SYMBOL: objects
! Constants
: image-magic HEX: 0f0e0d0c ; inline
: image-version 4 ; inline
CONSTANT: image-magic HEX: 0f0e0d0c
CONSTANT: image-version 4
: data-base 1024 ; inline
CONSTANT: data-base 1024
: userenv-size 70 ; inline
CONSTANT: userenv-size 70
: header-size 10 ; inline
CONSTANT: header-size 10
: data-heap-size-offset 3 ; inline
: t-offset 6 ; inline
: 0-offset 7 ; inline
: 1-offset 8 ; inline
: -1-offset 9 ; inline
CONSTANT: data-heap-size-offset 3
CONSTANT: t-offset 6
CONSTANT: 0-offset 7
CONSTANT: 1-offset 8
CONSTANT: -1-offset 9
SYMBOL: sub-primitives

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

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

2
basis/calendar/calendar.factor
View File

@ -61,7 +61,7 @@ PRIVATE>
: month-abbreviation ( n -- string )
check-month 1- month-abbreviations nth ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
: day-names ( -- array )
{

2
basis/checksums/adler-32/adler-32.factor
View File

@ -6,7 +6,7 @@ IN: checksums.adler-32
SINGLETON: adler-32
: adler-32-modulus 65521 ; inline
CONSTANT: adler-32-modulus 65521
M: adler-32 checksum-bytes ( bytes checksum -- value )
drop

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

@ -1,5 +1,5 @@
IN: checksums.openssl
USING: help.syntax help.markup ;
USING: checksums help.syntax help.markup ;
HELP: openssl-checksum
{ $class-description "The class of checksum algorithms implemented by OpenSSL. The exact set of algorithms supported depends on how the OpenSSL library was compiled; " { $snippet "md5" } " and " { $snippet "sha1" } " should be universally available." } ;
@ -9,9 +9,11 @@ HELP: <openssl-checksum>
{ $description "Creates a new OpenSSL checksum object." } ;
HELP: openssl-md5
{ $values { "value" checksum } }
{ $description "The OpenSSL MD5 message digest implementation." } ;
HELP: openssl-sha1
{ $values { "value" checksum } }
{ $description "The OpenSSL SHA1 message digest implementation." } ;
HELP: unknown-digest

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

@ -9,9 +9,9 @@ ERROR: unknown-digest 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

16
basis/checksums/sha2/sha2.factor
View File

@ -9,14 +9,14 @@ IN: checksums.sha2
SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
: a 0 ; inline
: b 1 ; inline
: c 2 ; inline
: d 3 ; inline
: e 4 ; inline
: f 5 ; inline
: g 6 ; inline
: h 7 ; inline
CONSTANT: a 0
CONSTANT: b 1
CONSTANT: c 2
CONSTANT: d 3
CONSTANT: e 4
CONSTANT: f 5
CONSTANT: g 6
CONSTANT: h 7
: initial-H-256 ( -- seq )
{

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

@ -19,9 +19,9 @@ IN: cocoa.application
] curry assoc-each
] keep ;
: NSApplicationDelegateReplySuccess 0 ;
: NSApplicationDelegateReplyCancel 1 ;
: NSApplicationDelegateReplyFailure 2 ;
CONSTANT: NSApplicationDelegateReplySuccess 0
CONSTANT: NSApplicationDelegateReplyCancel 1
CONSTANT: NSApplicationDelegateReplyFailure 2
: with-autorelease-pool ( quot -- )
NSAutoreleasePool -> new slip -> release ; inline

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

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

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

@ -5,7 +5,7 @@ sequences vectors fry libc destructors
specialized-arrays.direct.alien ;
IN: cocoa.enumeration
: NS-EACH-BUFFER-SIZE 16 ; inline
CONSTANT: NS-EACH-BUFFER-SIZE 16
: with-enumeration-buffers ( quot -- )
[

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

@ -1,11 +1,11 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
continuations combinators compiler compiler.alien kernel math
namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private parser lexer init core-foundation fry
generalizations specialized-arrays.direct.alien call ;
continuations combinators compiler compiler.alien stack-checker kernel
math namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
libc.private parser lexer init core-foundation fry generalizations
specialized-arrays.direct.alien call ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -14,7 +14,7 @@ IN: cocoa.messages
: sender-stub ( method function -- word )
[ "( sender-stub )" f <word> dup ] 2dip
over first large-struct? [ "_stret" append ] when
make-sender define ;
make-sender dup infer define-declared ;
SYMBOL: 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 ;
IN: cocoa.pasteboard
: NSStringPboardType "NSStringPboardType" ;
CONSTANT: NSStringPboardType "NSStringPboardType"
: pasteboard-string? ( pasteboard -- ? )
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" }
{ "Class" "class" } ;
: CLS_CLASS HEX: 1 ;
: CLS_META HEX: 2 ;
: CLS_INITIALIZED HEX: 4 ;
: CLS_POSING HEX: 8 ;
: CLS_MAPPED HEX: 10 ;
: CLS_FLUSH_CACHE HEX: 20 ;
: CLS_GROW_CACHE HEX: 40 ;
: CLS_NEED_BIND HEX: 80 ;
: CLS_METHOD_ARRAY HEX: 100 ;
CONSTANT: CLS_CLASS HEX: 1
CONSTANT: CLS_META HEX: 2
CONSTANT: CLS_INITIALIZED HEX: 4
CONSTANT: CLS_POSING HEX: 8
CONSTANT: CLS_MAPPED HEX: 10
CONSTANT: CLS_FLUSH_CACHE HEX: 20
CONSTANT: CLS_GROW_CACHE HEX: 40
CONSTANT: CLS_NEED_BIND HEX: 80
CONSTANT: CLS_METHOD_ARRAY HEX: 100
FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;

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

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

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

@ -5,43 +5,43 @@ cocoa cocoa.messages cocoa.classes cocoa.types sequences
continuations accessors ;
IN: cocoa.views
: NSOpenGLPFAAllRenderers 1 ;
: NSOpenGLPFADoubleBuffer 5 ;
: NSOpenGLPFAStereo 6 ;
: NSOpenGLPFAAuxBuffers 7 ;
: NSOpenGLPFAColorSize 8 ;
: NSOpenGLPFAAlphaSize 11 ;
: NSOpenGLPFADepthSize 12 ;
: NSOpenGLPFAStencilSize 13 ;
: NSOpenGLPFAAccumSize 14 ;
: NSOpenGLPFAMinimumPolicy 51 ;
: NSOpenGLPFAMaximumPolicy 52 ;
: NSOpenGLPFAOffScreen 53 ;
: NSOpenGLPFAFullScreen 54 ;
: NSOpenGLPFASampleBuffers 55 ;
: NSOpenGLPFASamples 56 ;
: NSOpenGLPFAAuxDepthStencil 57 ;
: NSOpenGLPFAColorFloat 58 ;
: NSOpenGLPFAMultisample 59 ;
: NSOpenGLPFASupersample 60 ;
: NSOpenGLPFASampleAlpha 61 ;
: NSOpenGLPFARendererID 70 ;
: NSOpenGLPFASingleRenderer 71 ;
: NSOpenGLPFANoRecovery 72 ;
: NSOpenGLPFAAccelerated 73 ;
: NSOpenGLPFAClosestPolicy 74 ;
: NSOpenGLPFARobust 75 ;
: NSOpenGLPFABackingStore 76 ;
: NSOpenGLPFAMPSafe 78 ;
: NSOpenGLPFAWindow 80 ;
: NSOpenGLPFAMultiScreen 81 ;
: NSOpenGLPFACompliant 83 ;
: NSOpenGLPFAScreenMask 84 ;
: NSOpenGLPFAPixelBuffer 90 ;
: NSOpenGLPFAAllowOfflineRenderers 96 ;
: NSOpenGLPFAVirtualScreenCount 128 ;
CONSTANT: NSOpenGLPFAAllRenderers 1
CONSTANT: NSOpenGLPFADoubleBuffer 5
CONSTANT: NSOpenGLPFAStereo 6
CONSTANT: NSOpenGLPFAAuxBuffers 7
CONSTANT: NSOpenGLPFAColorSize 8
CONSTANT: NSOpenGLPFAAlphaSize 11
CONSTANT: NSOpenGLPFADepthSize 12
CONSTANT: NSOpenGLPFAStencilSize 13
CONSTANT: NSOpenGLPFAAccumSize 14
CONSTANT: NSOpenGLPFAMinimumPolicy 51
CONSTANT: NSOpenGLPFAMaximumPolicy 52
CONSTANT: NSOpenGLPFAOffScreen 53
CONSTANT: NSOpenGLPFAFullScreen 54
CONSTANT: NSOpenGLPFASampleBuffers 55
CONSTANT: NSOpenGLPFASamples 56
CONSTANT: NSOpenGLPFAAuxDepthStencil 57
CONSTANT: NSOpenGLPFAColorFloat 58
CONSTANT: NSOpenGLPFAMultisample 59
CONSTANT: NSOpenGLPFASupersample 60
CONSTANT: NSOpenGLPFASampleAlpha 61
CONSTANT: NSOpenGLPFARendererID 70
CONSTANT: NSOpenGLPFASingleRenderer 71
CONSTANT: NSOpenGLPFANoRecovery 72
CONSTANT: NSOpenGLPFAAccelerated 73
CONSTANT: NSOpenGLPFAClosestPolicy 74
CONSTANT: NSOpenGLPFARobust 75
CONSTANT: NSOpenGLPFABackingStore 76
CONSTANT: NSOpenGLPFAMPSafe 78
CONSTANT: NSOpenGLPFAWindow 80
CONSTANT: NSOpenGLPFAMultiScreen 81
CONSTANT: NSOpenGLPFACompliant 83
CONSTANT: NSOpenGLPFAScreenMask 84
CONSTANT: NSOpenGLPFAPixelBuffer 90
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
: kCGLRendererGenericFloatID HEX: 00020400 ;
CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
<PRIVATE
@ -94,7 +94,7 @@ PRIVATE>
USE: opengl.gl
USE: alien.syntax
: NSOpenGLCPSwapInterval 222 ;
CONSTANT: NSOpenGLCPSwapInterval 222
LIBRARY: OpenGL

16
basis/cocoa/windows/windows.factor
View File

@ -4,15 +4,15 @@ USING: arrays kernel math cocoa cocoa.messages cocoa.classes
sequences math.bitwise ;
IN: cocoa.windows
: NSBorderlessWindowMask 0 ; inline
: NSTitledWindowMask 1 ; inline
: NSClosableWindowMask 2 ; inline
: NSMiniaturizableWindowMask 4 ; inline
: NSResizableWindowMask 8 ; inline
CONSTANT: NSBorderlessWindowMask 0
CONSTANT: NSTitledWindowMask 1
CONSTANT: NSClosableWindowMask 2
CONSTANT: NSMiniaturizableWindowMask 4
CONSTANT: NSResizableWindowMask 8
: NSBackingStoreRetained 0 ; inline
: NSBackingStoreNonretained 1 ; inline
: NSBackingStoreBuffered 2 ; inline
CONSTANT: NSBackingStoreRetained 0
CONSTANT: NSBackingStoreNonretained 1
CONSTANT: NSBackingStoreBuffered 2
: standard-window-type ( -- n )
{

26
basis/colors/colors.factor
View File

@ -18,16 +18,16 @@ M: color red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ;
M: color blue>> ( color -- blue ) >rgba blue>> ;
: black T{ rgba f 0.0 0.0 0.0 1.0 } ; inline
: blue T{ rgba f 0.0 0.0 1.0 1.0 } ; inline
: cyan T{ rgba f 0 0.941 0.941 1 } ; inline
: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; inline
: green T{ rgba f 0.0 1.0 0.0 1.0 } ; inline
: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; inline
: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; inline
: magenta T{ rgba f 0.941 0 0.941 1 } ; inline
: orange T{ rgba f 0.941 0.627 0 1 } ; inline
: purple T{ rgba f 0.627 0 0.941 1 } ; inline
: red T{ rgba f 1.0 0.0 0.0 1.0 } ; inline
: white T{ rgba f 1.0 1.0 1.0 1.0 } ; inline
: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; inline
CONSTANT: black T{ rgba f 0.0 0.0 0.0 1.0 }
CONSTANT: blue T{ rgba f 0.0 0.0 1.0 1.0 }
CONSTANT: cyan T{ rgba f 0 0.941 0.941 1 }
CONSTANT: gray T{ rgba f 0.6 0.6 0.6 1.0 }
CONSTANT: green T{ rgba f 0.0 1.0 0.0 1.0 }
CONSTANT: light-gray T{ rgba f 0.95 0.95 0.95 0.95 }
CONSTANT: light-purple T{ rgba f 0.8 0.8 1.0 1.0 }
CONSTANT: magenta T{ rgba f 0.941 0 0.941 1 }
CONSTANT: orange T{ rgba f 0.941 0.627 0 1 }
CONSTANT: purple T{ rgba f 0.627 0 0.941 1 }
CONSTANT: red T{ rgba f 1.0 0.0 0.0 1.0 }
CONSTANT: white T{ rgba f 1.0 1.0 1.0 1.0 }
CONSTANT: yellow T{ rgba f 1.0 1.0 0.0 1.0 }

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

@ -16,7 +16,7 @@ M: callable test-cfg
build-tree optimize-tree gensym build-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?

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

@ -1,5 +1,5 @@
USING: help.markup help.syntax words io parser
assocs words.private sequences compiler.units ;
assocs words.private sequences compiler.units quotations ;
IN: compiler
HELP: enable-compiler
@ -16,6 +16,8 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile }
"Compiling a single quotation:"
{ $subsection compile-call }
"Higher-level words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler"
@ -48,3 +50,8 @@ HELP: optimized-recompile-hook
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
{ $description "Compile a set of words." }
{ $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.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io
words fry continuations vocabs assocs dlists definitions math
graphs generic combinators deques search-deques io
stack-checker stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder
compiler.cfg.optimizer compiler.cfg.linearization
compiler.cfg.two-operand compiler.cfg.linear-scan
compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs
generic combinators deques search-deques io stack-checker
stack-checker.state stack-checker.inlining
combinators.short-circuit compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.linear-scan compiler.cfg.stack-frame
compiler.codegen compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
SYMBOL: compiled
: queue-compile ( word -- )
: queue-compile? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
[ "forgotten" word-prop ]
[ compiled get key? ]
[ inlined-block? ]
[ primitive? ]
} 1|| not ;
: queue-compile ( word -- )
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
: maybe-compile ( word -- )
dup optimized>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+
SYMBOLS: +optimized+ +unoptimized+ ;
: ripple-up ( words -- )
dup "compiled-effect" word-prop +failed+ eq?
dup "compiled-status" word-prop +unoptimized+ eq?
[ usage [ word? ] filter ] [ compiled-usage keys ] if
[ queue-compile ] each ;
: ripple-up? ( word effect -- ? )
#! If the word has previously been compiled and had a
#! different stack effect, we have to recompile any callers.
swap "compiled-effect" word-prop [ = not ] keep and ;
: ripple-up? ( word status -- ? )
swap "compiled-status" word-prop [ = not ] keep and ;
: save-effect ( word effect -- )
: save-compiled-status ( word status -- )
[ dupd ripple-up? [ ripple-up ] [ drop ] if ]
[ "compiled-effect" set-word-prop ]
[ "compiled-status" set-word-prop ]
2bi ;
: start ( word -- )
@ -49,18 +50,18 @@ SYMBOL: +failed+
H{ } clone generic-dependencies set
f swap compiler-error ;
: fail ( word error -- )
: fail ( word error -- * )
[ swap compiler-error ]
[
drop
[ compiled-unxref ]
[ f swap compiled get set-at ]
[ +failed+ save-effect ]
[ +unoptimized+ save-compiled-status ]
tri
] 2bi
return ;
: frontend ( word -- effect nodes )
: frontend ( word -- nodes )
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
! Only switch this off for debugging.
@ -84,8 +85,8 @@ t compile-dependencies? set-global
save-asm
] each ;
: finish ( effect word -- )
[ swap save-effect ]
: finish ( word -- )
[ +optimized+ save-compiled-status ]
[ compiled-unxref ]
[
dup crossref?
@ -112,6 +113,9 @@ t compile-dependencies? set-global
: decompile ( word -- )
f 2array 1array modify-code-heap ;
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
: optimized-recompile-hook ( words -- alist )
[
<hashed-dlist> compile-queue set

38
basis/compiler/constants/constants.factor
View File

@ -4,8 +4,8 @@ USING: math kernel layouts system strings ;
IN: compiler.constants
! These constants must match vm/memory.h
: card-bits 8 ; inline
: deck-bits 18 ; inline
CONSTANT: card-bits 8
CONSTANT: deck-bits 18
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
! These constants must match vm/layouts.h
@ -26,25 +26,25 @@ IN: compiler.constants
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
: rc-absolute-cell 0 ; inline
: rc-absolute 1 ; inline
: rc-relative 2 ; inline
: rc-absolute-ppc-2/2 3 ; inline
: rc-relative-ppc-2 4 ; inline
: rc-relative-ppc-3 5 ; inline
: rc-relative-arm-3 6 ; inline
: rc-indirect-arm 7 ; inline
: rc-indirect-arm-pc 8 ; inline
CONSTANT: rc-absolute-cell 0
CONSTANT: rc-absolute 1
CONSTANT: rc-relative 2
CONSTANT: rc-absolute-ppc-2/2 3
CONSTANT: rc-relative-ppc-2 4
CONSTANT: rc-relative-ppc-3 5
CONSTANT: rc-relative-arm-3 6
CONSTANT: rc-indirect-arm 7
CONSTANT: rc-indirect-arm-pc 8
! Relocation types
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-dispatch 2 ; inline
: rt-xt 3 ; inline
: rt-here 4 ; inline
: rt-label 5 ; inline
: rt-immediate 6 ; inline
: rt-stack-chain 7 ; inline
CONSTANT: rt-primitive 0
CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
CONSTANT: rt-here 4
CONSTANT: rt-label 5
CONSTANT: rt-immediate 6
CONSTANT: rt-stack-chain 7
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]

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

@ -51,7 +51,7 @@ unit-test
\ foo [ global >n get ndrop ] compile-call
] unit-test
: blech drop ;
: blech ( x -- ) drop ;
[ 3 ]
[
@ -102,7 +102,7 @@ unit-test
[ ] [
[
[ 200 dup [ 200 3array ] curry map drop ] times
] [ define-temp ] with-compilation-unit drop
] [ (( n -- )) define-temp ] with-compilation-unit drop
] unit-test
! 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
assocs namespaces make compiler.units ;
assocs namespaces make compiler.units compiler ;
IN: compiler.tests
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
@ -32,15 +32,15 @@ IN: compiler.tests
compile-call
] unit-test
: foobar ( quot -- )
dup slip swap [ foobar ] [ drop ] if ; inline
: foobar ( quot: ( -- ) -- )
dup slip swap [ foobar ] [ drop ] if ; inline recursive
[ ] [ [ [ 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
: funky-assoc>map
: funky-assoc>map ( assoc quot -- seq )
[
[ call f ] curry assoc-find 3drop
] { } make ; inline

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

@ -1,5 +1,5 @@
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 ;
[ 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
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii
classes ;
classes compiler ;
IN: compiler.tests
! 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
quotations classes classes.algebra classes.tuple.private
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
GENERIC: xyz ( obj -- obj )
@ -54,7 +55,7 @@ TUPLE: pred-test ;
! regression
: literal-not-branch 0 not [ ] [ ] if ;
: literal-not-branch ( -- ) 0 not [ ] [ ] if ;
[ ] [ literal-not-branch ] unit-test
@ -107,12 +108,12 @@ GENERIC: void-generic ( obj -- * )
[ 10 ] [ branch-fold-regression-1 ] unit-test
! 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
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression
: foo f ;
: foo ( -- value ) f ;
: bar ( -- ? ) foo 4 4 = and ;
[ f ] [ bar ] unit-test
@ -133,15 +134,15 @@ M: slice foozul ;
] unit-test
! regression
: constant-fold-2 f ; foldable
: constant-fold-3 4 ; foldable
: constant-fold-2 ( -- value ) f ; foldable
: constant-fold-3 ( -- value ) 4 ; foldable
[ f t ] [
[ constant-fold-2 constant-fold-3 4 = ] compile-call
] unit-test
: constant-fold-4 f ; foldable
: constant-fold-5 f ; foldable
: constant-fold-4 ( -- value ) f ; foldable
: constant-fold-5 ( -- value ) f ; foldable
[ f ] [
[ constant-fold-4 constant-fold-5 or ] compile-call
@ -208,14 +209,14 @@ USE: sorting
USE: binary-search
USE: binary-search.private
: old-binsearch ( elt quot seq -- elt quot i )
: old-binsearch ( elt quot: ( -- ) seq -- elt quot i )
dup length 1 <= [
from>>
] [
[ midpoint swap call ] 3keep roll dup zero?
[ drop dup from>> swap midpoint@ + ]
[ dup midpoint@ cut-slice old-binsearch ] if
] if ; inline
[ drop dup midpoint@ head-slice old-binsearch ] if
] if ; inline recursive
[ 10 ] [
10 20 >vector <flat-slice>
@ -246,7 +247,7 @@ USE: binary-search.private
[ 3 "an integer" ] [ 3 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? [
[ [ 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
] 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 ;
\ lift-loop-tail-test-2 must-infer
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
! Forgot a recursive inline check
@ -300,7 +303,7 @@ HINTS: recursive-inline-hang-3 array ;
: member-test ( obj -- ? ) { + - * / /i } member? ;
\ 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
[ 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
! Calls
: no-op ;
: no-op ( -- ) ;
[ ] [ [ no-op ] compile-call ] unit-test
[ 3 ] [ [ no-op 3 ] 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 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
@ -54,7 +54,7 @@ IN: compiler.tests
! Labels
: recursive-test ( ? -- ) [ f recursive-test ] when ; inline
: recursive-test ( ? -- ) [ f recursive-test ] when ; inline recursive
[ ] [ t [ recursive-test ] compile-call ] unit-test

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

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

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

@ -474,7 +474,7 @@ cell-bits 32 = [
] unit-test
! A reduction
: buffalo-sauce f ;
: buffalo-sauce ( -- value ) f ;
: steak ( -- )
buffalo-sauce [ steak ] when ; inline recursive
@ -510,3 +510,8 @@ cell-bits 32 = [
[ { array } declare 2 <groups> [ . . ] assoc-each ]
\ nth-unsafe inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare = ]
\ both-fixnums? inlined?
] unit-test

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

@ -5,9 +5,9 @@ IN: compiler.tree.comparisons
! 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 )
{

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

@ -144,7 +144,7 @@ SYMBOL: node-count
: 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
H{ } clone words-called set

4
basis/compiler/tree/propagation/info/info.factor
View File

@ -32,9 +32,9 @@ literal?
length
slots ;
: null-info T{ value-info f null empty-interval } ; inline
CONSTANT: null-info T{ value-info f null empty-interval }
: object-info T{ value-info f object full-interval } ; inline
CONSTANT: object-info T{ value-info f object full-interval }
: class-interval ( class -- interval )
dup real class<=

7
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -199,8 +199,11 @@ generic-comparison-ops [
] "outputs" set-word-prop
\ both-fixnums? [
[ class>> fixnum classes-intersect? not ] either?
f <literal-info> object-info ?
[ class>> ] bi@ {
{ [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
{ [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
[ object-info ]
} cond 2nip
] "outputs" set-word-prop
{

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

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

4
basis/compression/lzw/lzw.factor
View File

@ -69,11 +69,11 @@ ERROR: index-too-big n ;
: omega-k-in-table? ( lzw -- ? )
[ omega-k>> ] [ table>> ] bi key? ;
ERROR: not-in-table ;
ERROR: not-in-table value ;
: write-output ( lzw -- )
[
[ omega>> ] [ table>> ] bi at* [ not-in-table ] unless
[ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless
] [
[ lzw-bit-width-compress ]
[ output>> write-bits ] bi

2
basis/core-foundation/core-foundation.factor
View File

@ -6,7 +6,7 @@ IN: core-foundation
TYPEDEF: void* CFTypeRef
TYPEDEF: void* CFAllocatorRef
: kCFAllocatorDefault f ; inline
CONSTANT: kCFAllocatorDefault f
TYPEDEF: bool Boolean
TYPEDEF: long CFIndex

40
basis/core-foundation/data/data.factor
View File

@ -10,28 +10,28 @@ TYPEDEF: void* CFNumberRef
TYPEDEF: void* CFSetRef
TYPEDEF: int CFNumberType
: kCFNumberSInt8Type 1 ; inline
: kCFNumberSInt16Type 2 ; inline
: kCFNumberSInt32Type 3 ; inline
: kCFNumberSInt64Type 4 ; inline
: kCFNumberFloat32Type 5 ; inline
: kCFNumberFloat64Type 6 ; inline
: kCFNumberCharType 7 ; inline
: kCFNumberShortType 8 ; inline
: kCFNumberIntType 9 ; inline
: kCFNumberLongType 10 ; inline
: kCFNumberLongLongType 11 ; inline
: kCFNumberFloatType 12 ; inline
: kCFNumberDoubleType 13 ; inline
: kCFNumberCFIndexType 14 ; inline
: kCFNumberNSIntegerType 15 ; inline
: kCFNumberCGFloatType 16 ; inline
: kCFNumberMaxType 16 ; inline
CONSTANT: kCFNumberSInt8Type 1
CONSTANT: kCFNumberSInt16Type 2
CONSTANT: kCFNumberSInt32Type 3
CONSTANT: kCFNumberSInt64Type 4
CONSTANT: kCFNumberFloat32Type 5
CONSTANT: kCFNumberFloat64Type 6
CONSTANT: kCFNumberCharType 7
CONSTANT: kCFNumberShortType 8
CONSTANT: kCFNumberIntType 9
CONSTANT: kCFNumberLongType 10
CONSTANT: kCFNumberLongLongType 11
CONSTANT: kCFNumberFloatType 12
CONSTANT: kCFNumberDoubleType 13
CONSTANT: kCFNumberCFIndexType 14
CONSTANT: kCFNumberNSIntegerType 15
CONSTANT: kCFNumberCGFloatType 16
CONSTANT: kCFNumberMaxType 16
TYPEDEF: int CFPropertyListMutabilityOptions
: kCFPropertyListImmutable 0 ; inline
: kCFPropertyListMutableContainers 1 ; inline
: kCFPropertyListMutableContainersAndLeaves 2 ; inline
CONSTANT: kCFPropertyListImmutable 0
CONSTANT: kCFPropertyListMutableContainers 1
CONSTANT: kCFPropertyListMutableContainersAndLeaves 2
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;

4
basis/core-foundation/file-descriptors/file-descriptors.factor
View File

@ -15,8 +15,8 @@ FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
CFFileDescriptorContext* context
) ;
: kCFFileDescriptorReadCallBack 1 ; inline
: kCFFileDescriptorWriteCallBack 2 ; inline
CONSTANT: kCFFileDescriptorReadCallBack 1
CONSTANT: kCFFileDescriptorWriteCallBack 2
FUNCTION: void CFFileDescriptorEnableCallBacks (
CFFileDescriptorRef f,

22
basis/core-foundation/fsevents/fsevents.factor
View File

@ -9,17 +9,17 @@ core-foundation core-foundation.run-loop core-foundation.strings
core-foundation.time ;
IN: core-foundation.fsevents
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
: kFSEventStreamCreateFlagWatchRoot 4 ; inline
CONSTANT: kFSEventStreamCreateFlagUseCFTypes 2
CONSTANT: kFSEventStreamCreateFlagWatchRoot 4
: kFSEventStreamEventFlagMustScanSubDirs 1 ; inline
: kFSEventStreamEventFlagUserDropped 2 ; inline
: kFSEventStreamEventFlagKernelDropped 4 ; inline
: kFSEventStreamEventFlagEventIdsWrapped 8 ; inline
: kFSEventStreamEventFlagHistoryDone 16 ; inline
: kFSEventStreamEventFlagRootChanged 32 ; inline
: kFSEventStreamEventFlagMount 64 ; inline
: kFSEventStreamEventFlagUnmount 128 ; inline
CONSTANT: kFSEventStreamEventFlagMustScanSubDirs 1
CONSTANT: kFSEventStreamEventFlagUserDropped 2
CONSTANT: kFSEventStreamEventFlagKernelDropped 4
CONSTANT: kFSEventStreamEventFlagEventIdsWrapped 8
CONSTANT: kFSEventStreamEventFlagHistoryDone 16
CONSTANT: kFSEventStreamEventFlagRootChanged 32
CONSTANT: kFSEventStreamEventFlagMount 64
CONSTANT: kFSEventStreamEventFlagUnmount 128
TYPEDEF: int FSEventStreamCreateFlags
TYPEDEF: int FSEventStreamEventFlags
@ -36,7 +36,7 @@ C-STRUCT: FSEventStreamContext
! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
TYPEDEF: void* FSEventStreamCallback
: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF ; inline
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
FUNCTION: FSEventStreamRef FSEventStreamCreate (
CFAllocatorRef allocator,

8
basis/core-foundation/run-loop/run-loop.factor
View File

@ -7,10 +7,10 @@ core-foundation.file-descriptors core-foundation.timers
core-foundation.time ;
IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline
: kCFRunLoopRunStopped 2 ; inline
: kCFRunLoopRunTimedOut 3 ; inline
: kCFRunLoopRunHandledSource 4 ; inline
CONSTANT: kCFRunLoopRunFinished 1
CONSTANT: kCFRunLoopRunStopped 2
CONSTANT: kCFRunLoopRunTimedOut 3
CONSTANT: kCFRunLoopRunHandledSource 4
TYPEDEF: void* CFRunLoopRef
TYPEDEF: void* CFRunLoopSourceRef

28
basis/core-foundation/strings/strings.factor
View File

@ -7,20 +7,20 @@ IN: core-foundation.strings
TYPEDEF: void* CFStringRef
TYPEDEF: int CFStringEncoding
: kCFStringEncodingMacRoman HEX: 0 ;
: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
: kCFStringEncodingISOLatin1 HEX: 0201 ;
: kCFStringEncodingNextStepLatin HEX: 0B01 ;
: kCFStringEncodingASCII HEX: 0600 ;
: kCFStringEncodingUnicode HEX: 0100 ;
: kCFStringEncodingUTF8 HEX: 08000100 ;
: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
: kCFStringEncodingUTF16 HEX: 0100 ;
: kCFStringEncodingUTF16BE HEX: 10000100 ;
: kCFStringEncodingUTF16LE HEX: 14000100 ;
: kCFStringEncodingUTF32 HEX: 0c000100 ;
: kCFStringEncodingUTF32BE HEX: 18000100 ;
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
CONSTANT: kCFStringEncodingMacRoman HEX: 0
CONSTANT: kCFStringEncodingWindowsLatin1 HEX: 0500
CONSTANT: kCFStringEncodingISOLatin1 HEX: 0201
CONSTANT: kCFStringEncodingNextStepLatin HEX: 0B01
CONSTANT: kCFStringEncodingASCII HEX: 0600
CONSTANT: kCFStringEncodingUnicode HEX: 0100
CONSTANT: kCFStringEncodingUTF8 HEX: 08000100
CONSTANT: kCFStringEncodingNonLossyASCII HEX: 0BFF
CONSTANT: kCFStringEncodingUTF16 HEX: 0100
CONSTANT: kCFStringEncodingUTF16BE HEX: 10000100
CONSTANT: kCFStringEncodingUTF16LE HEX: 14000100
CONSTANT: kCFStringEncodingUTF32 HEX: 0c000100
CONSTANT: kCFStringEncodingUTF32BE HEX: 18000100
CONSTANT: kCFStringEncodingUTF32LE HEX: 1c000100
FUNCTION: CFStringRef CFStringCreateWithBytes (
CFAllocatorRef alloc,

2
basis/core-foundation/urls/urls.factor
View File

@ -4,7 +4,7 @@ USING: alien.syntax kernel core-foundation.strings
core-foundation ;
IN: core-foundation.urls
: kCFURLPOSIXPathStyle 0 ; inline
CONSTANT: kCFURLPOSIXPathStyle 0
TYPEDEF: void* CFURLRef

8
basis/cpu/ppc/ppc.factor
View File

@ -27,8 +27,8 @@ M: ppc machine-registers
{ double-float-regs T{ range f 0 29 1 } }
} ;
: scratch-reg 28 ; inline
: fp-scratch-reg 30 ; inline
CONSTANT: scratch-reg 28
CONSTANT: fp-scratch-reg 30
M: ppc two-operand? f ;
@ -40,8 +40,8 @@ M: ppc %load-reference ( reg obj -- )
M: ppc %alien-global ( register symbol dll -- )
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
: ds-reg 29 ; inline
: rs-reg 30 ; inline
CONSTANT: ds-reg 29
CONSTANT: rs-reg 30
GENERIC: loc-reg ( loc -- reg )

13
basis/db/db.factor
View File

@ -2,17 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations destructors kernel math
namespaces sequences classes.tuple words strings
tools.walker accessors combinators fry ;
tools.walker accessors combinators fry db.errors ;
IN: db
<PRIVATE
TUPLE: db-connection
handle
insert-statements
update-statements
delete-statements ;
<PRIVATE
: new-db-connection ( class -- obj )
new
H{ } clone >>insert-statements
@ -23,6 +23,7 @@ PRIVATE>
GENERIC: db-open ( db -- db-connection )
HOOK: db-close db-connection ( handle -- )
HOOK: parse-db-error db-connection ( error -- error' )
: dispose-statements ( assoc -- ) values dispose-each ;
@ -77,7 +78,11 @@ GENERIC: bind-tuple ( tuple statement -- )
GENERIC: execute-statement* ( statement type -- )
M: object execute-statement* ( statement type -- )
drop query-results dispose ;
'[
_ _ drop query-results dispose
] [
parse-db-error rethrow
] recover ;
: execute-one-statement ( statement -- )
dup type>> execute-statement* ;

50
basis/db/errors/errors.factor
View File

@ -1,10 +1,54 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ;
USING: accessors kernel continuations fry words ;
IN: db.errors
ERROR: db-error ;
ERROR: sql-error ;
ERROR: sql-error location ;
ERROR: table-exists ;
ERROR: bad-schema ;
ERROR: sql-unknown-error < sql-error message ;
: <sql-unknown-error> ( message -- error )
\ sql-unknown-error new
swap >>message ;
ERROR: sql-table-exists < sql-error table ;
: <sql-table-exists> ( table -- error )
\ sql-table-exists new
swap >>table ;
ERROR: sql-table-missing < sql-error table ;
: <sql-table-missing> ( table -- error )
\ sql-table-missing new
swap >>table ;
ERROR: sql-syntax-error < sql-error message ;
: <sql-syntax-error> ( message -- error )
\ sql-syntax-error new
swap >>message ;
ERROR: sql-function-exists < sql-error message ;
: <sql-function-exists> ( message -- error )
\ sql-function-exists new
swap >>message ;
ERROR: sql-function-missing < sql-error message ;
: <sql-function-missing> ( message -- error )
\ sql-function-missing new
swap >>message ;
: ignore-error ( quot word -- )
'[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline
: ignore-table-exists ( quot -- )
\ sql-table-exists? ignore-error ; inline
: ignore-table-missing ( quot -- )
\ sql-table-missing? ignore-error ; inline
: ignore-function-exists ( quot -- )
\ sql-function-exists? ignore-error ; inline
: ignore-function-missing ( quot -- )
\ sql-function-missing? ignore-error ; inline

1
basis/db/errors/postgresql/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

32
basis/db/errors/postgresql/postgresql-tests.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit db db.errors
db.errors.postgresql db.postgresql io.files.unique kernel namespaces
tools.test db.tester continuations ;
IN: db.errors.postgresql.tests
[
[ "drop table foo;" sql-command ] ignore-errors
[ "drop table ship;" sql-command ] ignore-errors
[
"insert into foo (id) values('1');" sql-command
] [
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
] must-fail-with
[
"create table ship(id integer);" sql-command
"create table ship(id integer);" sql-command
] [
{ [ sql-table-exists? ] [ table>> "ship" = ] } 1&&
] must-fail-with
[
"create table foo(id) lol;" sql-command
] [
sql-syntax-error?
] must-fail-with
] test-postgresql

53
basis/db/errors/postgresql/postgresql.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel db.errors peg.ebnf strings sequences math
combinators.short-circuit accessors math.parser quoting ;
IN: db.errors.postgresql
EBNF: parse-postgresql-sql-error
Error = "ERROR:" [ ]+
TableError =
Error ("relation "|"table ")(!(" already exists").)+:table " already exists"
=> [[ table >string unquote <sql-table-exists> ]]
| Error ("relation "|"table ")(!(" does not exist").)+:table " does not exist"
=> [[ table >string unquote <sql-table-missing> ]]
FunctionError =
Error "function" (!(" already exists").)+:table " already exists"
=> [[ table >string <sql-function-exists> ]]
| Error "function" (!(" does not exist").)+:table " does not exist"
=> [[ table >string <sql-function-missing> ]]
SyntaxError =
Error "syntax error at end of input":error
=> [[ error >string <sql-syntax-error> ]]
| Error "syntax error at or near " .+:syntaxerror
=> [[ syntaxerror >string unquote <sql-syntax-error> ]]
UnknownError = .* => [[ >string <sql-unknown-error> ]]
PostgresqlSqlError = (TableError | FunctionError | SyntaxError | UnknownError)
;EBNF
ERROR: parse-postgresql-location column line text ;
C: <parse-postgresql-location> parse-postgresql-location
EBNF: parse-postgresql-line-error
Line = "LINE " [0-9]+:line ": " .+:sql
=> [[ f line >string string>number sql >string <parse-postgresql-location> ]]
;EBNF
:: set-caret-position ( error caret-line -- error )
caret-line length
error line>> number>string length "LINE : " length +
- [ error ] dip >>column ;
: postgresql-location ( line column -- obj )
[ parse-postgresql-line-error ] dip
set-caret-position ;

1
basis/db/errors/sqlite/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

26
basis/db/errors/sqlite/sqlite-tests.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit db db.errors
db.errors.sqlite db.sqlite io.files.unique kernel namespaces
tools.test ;
IN: db.errors.sqlite.tests
: sqlite-error-test-db-path ( -- path )
"sqlite" "error-test" make-unique-file ;
sqlite-error-test-db-path <sqlite-db> [
[
"insert into foo (id) values('1');" sql-command
] [
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
] must-fail-with
[
"create table foo(id);" sql-command
"create table foo(id);" sql-command
] [
{ [ sql-table-exists? ] [ table>> "foo" = ] } 1&&
] must-fail-with
] with-db

25
basis/db/errors/sqlite/sqlite.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators db kernel sequences peg.ebnf
strings db.errors ;
IN: db.errors.sqlite
ERROR: unparsed-sqlite-error error ;
SINGLETONS: table-exists table-missing ;
: sqlite-table-error ( table message -- error )
{
{ table-exists [ <sql-table-exists> ] }
} case ;
EBNF: parse-sqlite-sql-error
TableMessage = " already exists" => [[ table-exists ]]
SqliteError =
"table " (!(TableMessage).)+:table TableMessage:message
=> [[ table >string message sqlite-table-error ]]
| "no such table: " .+:table
=> [[ table >string <sql-table-missing> ]]
;EBNF

29
basis/db/postgresql/postgresql-tests.factor
View File

@ -1,20 +1,13 @@
USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db db.private
db.tuples db.types unicode.case accessors system ;
db.tuples db.types unicode.case accessors system db.tester ;
IN: db.postgresql.tests
: test-db ( -- postgresql-db )
<postgresql-db>
"localhost" >>host
"postgres" >>username
"thepasswordistrust" >>password
"factor-test" >>database ;
os windows? cpu x86.64? and [
[ ] [ test-db [ ] with-db ] unit-test
[ ] [ postgresql-test-db [ ] with-db ] unit-test
[ ] [
test-db [
postgresql-test-db [
[ "drop table person;" sql-command ] ignore-errors
"create table person (name varchar(30), country varchar(30));"
sql-command
@ -30,7 +23,7 @@ os windows? cpu x86.64? and [
{ "Jane" "New Zealand" }
}
] [
test-db [
postgresql-test-db [
"select * from person" sql-query
] with-db
] unit-test
@ -40,11 +33,11 @@ os windows? cpu x86.64? and [
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
[
] [
test-db [
postgresql-test-db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-db
@ -56,10 +49,10 @@ os windows? cpu x86.64? and [
{ "Jane" "New Zealand" }
{ "Jimmy" "Canada" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
[
test-db [
postgresql-test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
@ -69,14 +62,14 @@ os windows? cpu x86.64? and [
] must-fail
[ 3 ] [
test-db [
postgresql-test-db [
"select * from person" sql-query length
] with-db
] unit-test
[
] [
test-db [
postgresql-test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
@ -87,7 +80,7 @@ os windows? cpu x86.64? and [
] unit-test
[ 5 ] [
test-db [
postgresql-test-db [
"select * from person" sql-query length
] with-db
] unit-test

15
basis/db/postgresql/postgresql.factor
View File

@ -5,8 +5,8 @@ kernel math math.parser namespaces make prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators classes locals words tools.walker db.private
nmake accessors random db.queries destructors db.tuples.private ;
USE: tools.walker
nmake accessors random db.queries destructors db.tuples.private
db.postgresql db.errors.postgresql splitting ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty database username password ;
@ -280,3 +280,14 @@ M: postgresql-db-connection compound ( string object -- string' )
{ "references" [ >reference-string ] }
[ drop no-compound-found ]
} case ;
M: postgresql-db-connection parse-db-error
"\n" split dup length {
{ 1 [ first parse-postgresql-sql-error ] }
{ 3 [
first3
[ parse-postgresql-sql-error ] 2dip
postgresql-location >>location
] }
} case ;

7
basis/db/sqlite/lib/lib.factor
View File

@ -11,12 +11,17 @@ IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
ERROR: sqlite-sql-error < sql-error n string ;
: <sqlite-sql-error> ( n string -- error )
\ sqlite-sql-error new
swap >>string
swap >>n ;
: throw-sqlite-error ( n -- * )
dup sqlite-error-messages nth sqlite-error ;
: sqlite-statement-error ( -- * )
SQLITE_ERROR
db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
db-connection get handle>> sqlite3_errmsg <sqlite-sql-error> throw ;
: sqlite-check-result ( n -- )
{

20
basis/db/sqlite/sqlite-tests.factor
View File

@ -123,12 +123,8 @@ hi "HELLO" {
] with-db
] unit-test
[ ] [
test.db [
hi create-table
hi drop-table
] with-db
] unit-test
! Test SQLite triggers
TUPLE: show id ;
TUPLE: user username data ;
@ -144,12 +140,12 @@ show "SHOW" {
} define-persistent
watch "WATCH" {
{ "user" "USER" TEXT +not-null+
{ +foreign-id+ user "USERNAME" } +user-assigned-id+ }
{ "show" "SHOW" BIG-INTEGER +not-null+
{ +foreign-id+ show "ID" } +user-assigned-id+ }
{ "user" "USER" TEXT +not-null+ +user-assigned-id+
{ +foreign-id+ user "USERNAME" } }
{ "show" "SHOW" BIG-INTEGER +not-null+ +user-assigned-id+
{ +foreign-id+ show "ID" } }
} define-persistent
[ T{ user { username "littledan" } { data "foo" } } ] [
test.db [
user create-table
@ -160,7 +156,7 @@ watch "WATCH" {
show new insert-tuple
show new select-tuple
"littledan" f user boa select-tuple
swap [ username>> ] [ id>> ] bi*
[ id>> ] [ username>> ] bi*
watch boa insert-tuple
watch new select-tuple
user>> f user boa select-tuple

98
basis/db/sqlite/sqlite.factor
View File

@ -6,7 +6,8 @@ sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors db.tuples.private interpolate
io.streams.string multiline make db.private sequences.deep ;
io.streams.string multiline make db.private sequences.deep
db.errors.sqlite ;
IN: db.sqlite
TUPLE: sqlite-db path ;
@ -204,7 +205,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
@ -216,28 +217,21 @@ M: sqlite-db-connection persistent-table ( -- assoc )
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE NEW.${foreign-table-id} IS NOT NULL
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
: drop-insert-trigger ( -- string )
[
<"
DROP TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
"> interpolate
] with-string-writer ;
: update-trigger ( -- string )
[
<"
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
@ -248,39 +242,25 @@ M: sqlite-db-connection persistent-table ( -- assoc )
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE NEW.${foreign-table-id} IS NOT NULL
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
: drop-update-trigger ( -- string )
[
<"
DROP TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
"> interpolate
] with-string-writer ;
: delete-trigger-restrict ( -- string )
[
<"
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END;
"> interpolate
] with-string-writer ;
: drop-delete-trigger-restrict ( -- string )
[
<"
DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
"> interpolate
] with-string-writer ;
: delete-trigger-cascade ( -- string )
[
<"
@ -292,13 +272,6 @@ M: sqlite-db-connection persistent-table ( -- assoc )
"> interpolate
] with-string-writer ;
: drop-delete-trigger-cascade ( -- string )
[
<"
DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
"> interpolate
] with-string-writer ;
: can-be-null? ( -- ? )
"sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
@ -322,31 +295,22 @@ M: sqlite-db-connection persistent-table ( -- assoc )
delete-trigger-restrict sqlite-trigger,
] if ;
: drop-sqlite-triggers ( -- )
drop-insert-trigger sqlite-trigger,
drop-update-trigger sqlite-trigger,
delete-cascade? [
drop-delete-trigger-cascade sqlite-trigger,
] [
drop-delete-trigger-restrict sqlite-trigger,
] if ;
: db-triggers ( sql-specs word -- )
'[
[ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
: create-db-triggers ( sql-specs -- )
[ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
[
[ class>> db-table-name "db-table" set ]
[
[ class>> db-table-name "db-table" set ]
[ "sql-spec" set ]
[ column-name>> "table-id" set ]
[ ] tri
modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
[
modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
[
[ second db-table-name "foreign-table-name" set ]
[ third "foreign-table-id" set ] bi
_ execute
] each
] tri
] each
] call ;
[ second db-table-name "foreign-table-name" set ]
[ third "foreign-table-id" set ] bi
create-sqlite-triggers
] each
] bi
] each ;
: sqlite-create-table ( sql-specs class-name -- )
[
@ -371,16 +335,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
M: sqlite-db-connection create-sql-statement ( class -- statement )
[
! specs name
[ sqlite-create-table ]
[ drop \ create-sqlite-triggers db-triggers ] 2bi
[ drop create-db-triggers ] 2bi
] query-make ;
M: sqlite-db-connection drop-sql-statement ( class -- statements )
[
[ nip "drop table " 0% 0% ";" 0% ]
[ drop \ drop-sqlite-triggers db-triggers ] 2bi
] query-make ;
[ nip "drop table " 0% 0% ";" 0% ] query-make ;
M: sqlite-db-connection compound ( string seq -- new-string )
over {
@ -388,3 +348,9 @@ M: sqlite-db-connection compound ( string seq -- new-string )
{ "references" [ >reference-string ] }
[ 2drop ]
} case ;
M: sqlite-db-connection parse-db-error
dup n>> {
{ 1 [ string>> parse-sqlite-sql-error ] }
[ drop ]
} case ;

38
basis/db/tester/tester.factor
View File

@ -2,9 +2,42 @@
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.combinators db.pools db.sqlite db.tuples
db.types kernel math random threads tools.test db sequences
io prettyprint ;
io prettyprint db.postgresql db.sqlite accessors io.files.temp
namespaces fry system ;
IN: db.tester
: postgresql-test-db ( -- postgresql-db )
<postgresql-db>
"localhost" >>host
"postgres" >>username
"thepasswordistrust" >>password
"factor-test" >>database ;
: sqlite-test-db ( -- sqlite-db )
"tuples-test.db" temp-file <sqlite-db> ;
! These words leak resources, but are useful for interactivel testing
: set-sqlite-db ( -- )
sqlite-db db-open db-connection set ;
: set-postgresql-db ( -- )
postgresql-db db-open db-connection set ;
: test-sqlite ( quot -- )
'[
[ ] [ sqlite-test-db _ with-db ] unit-test
] call ; inline
: test-postgresql ( quot -- )
'[
os windows? cpu x86.64? and [
[ ] [ postgresql-test-db _ with-db ] unit-test
] unless
] call ; inline
TUPLE: test-1 id a b c ;
test-1 "TEST1" {
@ -23,9 +56,6 @@ test-2 "TEST2" {
{ "z" "Z" { VARCHAR 256 } +not-null+ }
} define-persistent
: sqlite-test-db ( -- db ) "test.db" <sqlite-db> ;
: test-db ( -- db ) "test.db" <sqlite-db> ;
: db-tester ( test-db -- )
[
[

34
basis/db/tuples/tuples-tests.factor
View File

@ -4,40 +4,10 @@ USING: io.files io.files.temp kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise system
math.ranges strings urls fry db.tuples.private db.private ;
math.ranges strings urls fry db.tuples.private db.private
db.tester ;
IN: db.tuples.tests
: sqlite-db ( -- sqlite-db )
"tuples-test.db" temp-file <sqlite-db> ;
: test-sqlite ( quot -- )
'[
[ ] [
"tuples-test.db" temp-file <sqlite-db> _ with-db
] unit-test
] call ; inline
: postgresql-db ( -- postgresql-db )
<postgresql-db>
"localhost" >>host
"postgres" >>username
"thepasswordistrust" >>password
"factor-test" >>database ;
: test-postgresql ( quot -- )
'[
os windows? cpu x86.64? and [
[ ] [ postgresql-db _ with-db ] unit-test
] unless
] call ; inline
! These words leak resources, but are useful for interactivel testing
: sqlite-test-db ( -- )
sqlite-db db-open db-connection set ;
: postgresql-test-db ( -- )
postgresql-db db-open db-connection set ;
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob url ;

10
basis/db/tuples/tuples.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
destructors mirrors sets db.types db.private fry
combinators.short-circuit ;
combinators.short-circuit db.errors ;
IN: db.tuples
HOOK: create-sql-statement db-connection ( class -- object )
@ -118,13 +118,15 @@ ERROR: no-defined-persistent object ;
ensure-defined-persistent
[
'[
_ drop-sql-statement [ execute-statement ] with-disposals
] ignore-errors
[
_ drop-sql-statement [ execute-statement ] with-disposals
] ignore-table-missing
] ignore-function-missing
] [ create-table ] bi ;
: ensure-table ( class -- )
ensure-defined-persistent
'[ _ create-table ] ignore-errors ;
'[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
: ensure-tables ( classes -- ) [ ensure-table ] each ;

3
basis/db/types/types.factor
View File

@ -124,9 +124,6 @@ FACTOR-BLOB NULL URL ;
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
: ?at ( obj assoc -- value/obj ? )
dupd at* [ [ nip ] [ drop ] if ] keep ;
ERROR: unknown-modifier modifier ;
: lookup-modifier ( obj -- string )

2
basis/editors/editpadlite/editpadlite.factor
View File

@ -5,7 +5,7 @@ IN: editors.editpadlite
: editpadlite-path ( -- path )
\ editpadlite-path get-global [
"JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
"JGsoft" [ >lower "editpadlite.exe" tail? ] find-in-program-files
[ "editpadlite.exe" ] unless*
] unless* ;

2
basis/editors/editpadpro/editpadpro.factor
View File

@ -5,7 +5,7 @@ IN: editors.editpadpro
: editpadpro-path ( -- path )
\ editpadpro-path get-global [
"JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
"JGsoft" [ >lower "editpadpro.exe" tail? ] find-in-program-files
[ "editpadpro.exe" ] unless*
] unless* ;

2
basis/editors/editplus/editplus.factor
View File

@ -5,7 +5,7 @@ IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
"EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
"EditPlus 2" [ "editplus.exe" tail? ] find-in-program-files
[ "editplus.exe" ] unless*
] unless* ;

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

@ -1,17 +1,26 @@
USING: definitions io.launcher kernel parser words sequences math
math.parser namespaces editors make system ;
math.parser namespaces editors make system combinators.short-circuit
fry threads vocabs.loader ;
IN: editors.emacs
SYMBOL: emacsclient-path
HOOK: default-emacsclient os ( -- path )
M: object default-emacsclient ( -- path ) "emacsclient" ;
: emacsclient ( file line -- )
[
\ emacsclient get "emacsclient" or ,
os windows? [ "--no-wait" , ] unless
"+" swap number>string append ,
{ [ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
"--no-wait" ,
number>string "+" prepend ,
,
] { } make try-process ;
] { } make
os windows? [ run-detached drop ] [ try-process ] if ;
: emacs ( word -- )
where first2 emacsclient ;
[ emacsclient ] edit-hook set-global
os windows? [ "editors.emacs.windows" require ] when

0
extra/serial/authors.txt → basis/editors/emacs/windows/authors.txt Normal file → Executable file
View File

12
basis/editors/emacs/windows/windows.factor Executable file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: editors.emacs io.directories.search.windows kernel sequences
system combinators.short-circuit ;
IN: editors.emacs.windows
M: windows default-emacsclient
{
[ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ]
[ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ]
[ "emacsclient.exe" ]
} 0|| ;

2
basis/editors/emeditor/emeditor.factor
View File

@ -5,7 +5,7 @@ IN: editors.emeditor
: emeditor-path ( -- path )
\ emeditor-path get-global [
"EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
"EmEditor" [ "EmEditor.exe" tail? ] find-in-program-files
[ "EmEditor.exe" ] unless*
] unless* ;

2
basis/editors/etexteditor/etexteditor.factor
View File

@ -6,7 +6,7 @@ IN: editors.etexteditor
: etexteditor-path ( -- str )
\ etexteditor-path get-global [
"e" t [ "e.exe" tail? ] find-in-program-files
"e" [ "e.exe" tail? ] find-in-program-files
[ "e" ] unless*
] unless* ;

2
basis/editors/gvim/windows/windows.factor
View File

@ -5,6 +5,6 @@ IN: editors.gvim.windows
M: windows gvim-path
\ gvim-path get-global [
"vim" t [ "gvim.exe" tail? ] find-in-program-files
"vim" [ "gvim.exe" tail? ] find-in-program-files
[ "gvim.exe" ] unless*
] unless* ;

2
basis/editors/notepadpp/notepadpp.factor
View File

@ -4,7 +4,7 @@ IN: editors.notepadpp
: notepadpp-path ( -- path )
\ notepadpp-path get-global [
"notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
"notepad++" [ "notepad++.exe" tail? ] find-in-program-files
[ "notepad++.exe" ] unless*
] unless* ;

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

@ -7,11 +7,11 @@ IN: editors.scite
: scite-path ( -- path )
\ scite-path get-global [
"Scintilla Text Editor" t
"Scintilla Text Editor"
[ >lower "scite.exe" tail? ] find-in-program-files
[
"SciTE Source Code Editor" t
"SciTE Source Code Editor"
[ >lower "scite.exe" tail? ] find-in-program-files
] unless*
[ "scite.exe" ] unless*

2
basis/editors/ted-notepad/ted-notepad.factor
View File

@ -4,7 +4,7 @@ IN: editors.ted-notepad
: ted-notepad-path ( -- path )
\ ted-notepad-path get-global [
"TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
"TED Notepad" [ "TedNPad.exe" tail? ] find-in-program-files
[ "TedNPad.exe" ] unless*
] unless* ;

2
basis/editors/textpad/textpad.factor
View File

@ -5,7 +5,7 @@ IN: editors.textpad
: textpad-path ( -- path )
\ textpad-path get-global [
"TextPad 5" t [ "TextPad.exe" tail? ] find-in-program-files
"TextPad 5" [ "TextPad.exe" tail? ] find-in-program-files
[ "TextPad.exe" ] unless*
] unless* ;

2
basis/editors/ultraedit/ultraedit.factor
View File

@ -4,7 +4,7 @@ IN: editors.ultraedit
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
"IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
"IDM Computer Solutions" [ "uedit32.exe" tail? ] find-in-program-files
[ "uedit32.exe" ] unless*
] unless* ;

2
basis/editors/wordpad/wordpad.factor
View File

@ -4,7 +4,7 @@ IN: editors.wordpad
: wordpad-path ( -- path )
\ wordpad-path get [
"Windows NT\\Accessories" t
"Windows NT\\Accessories"
[ "wordpad.exe" tail? ] find-in-program-files
] unless* ;

2
basis/farkup/farkup.factor
View File

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

4
basis/functors/functors.factor
View File

@ -80,9 +80,9 @@ M: object fake-quotations> ;
scan-param parsed
\ 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

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

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

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

@ -10,7 +10,7 @@ furnace.auth.providers
furnace.auth.login.permits ;
IN: furnace.alloy
: state-classes { session aside conversation permit } ; inline
CONSTANT: state-classes { session aside conversation permit }
: init-furnace-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 }
} define-persistent
: aside-id-key "__a" ;
CONSTANT: aside-id-key "__a"
TUPLE: asides < server-state-manager ;

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

@ -64,7 +64,7 @@ SYMBOL: capabilities
PRIVATE>
: flashed-variables { description capabilities } ;
CONSTANT: flashed-variables { description capabilities }
: login-failed ( -- * )
"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 ;
IN: furnace.auth.providers.null
TUPLE: no-users ;
: no-users T{ no-users } ;
SINGLETON: no-users
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+ }
} define-persistent
: conversation-id-key "__c" ;
CONSTANT: conversation-id-key "__c"
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
sessions get responder>> call-responder ;
: session-id-key "__s" ;
CONSTANT: session-id-key "__s"
: verify-session ( session -- session )
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]
] [ drop ] if ;
: nested-forms-key "__n" ;
CONSTANT: nested-forms-key "__n"
: request-params ( request -- assoc )
dup method>> {
@ -131,7 +131,7 @@ M: object modify-form drop f ;
SYMBOL: exit-continuation
: exit-with ( value -- )
: exit-with ( value -- * )
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )

2
basis/help/topics/topics.factor
View File

@ -54,7 +54,7 @@ M: no-article summary
drop "Help article does not exist" ;
: article ( name -- article )
dup articles get at* [ nip ] [ drop no-article ] if ;
articles get ?at [ no-article ] unless ;
M: object article-name article article-name ;
M: object article-title article article-title ;

2
basis/hints/hints.factor
View File

@ -96,8 +96,6 @@ M: object specializer-declaration class ;
{ string string }
"specializer" set-word-prop
\ find-last-sep { string sbuf } "specializer" set-word-prop
\ >string { sbuf } "specializer" set-word-prop
\ >array { { vector } } "specializer" set-word-prop

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

@ -18,7 +18,7 @@ tags [ H{ } clone ] initialize
: CHLOE:
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 -- ? )
url>> chloe-ns = ;

3
basis/images/tiff/tiff.factor
View File

@ -243,9 +243,6 @@ ERROR: bad-tiff-magic bytes ;
ERROR: no-tag class ;
: ?at ( key assoc -- value/key ? )
dupd at* [ nip t ] [ drop f ] if ; inline
: find-tag ( idf class -- tag )
swap processed-tags>> ?at [ no-tag ] unless ;

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 ;
! Some general stuff
: file-mode OCT: 0666 ;
CONSTANT: file-mode OCT: 0666
! Readers
: (refill) ( port -- n )

2
basis/io/directories/search/search-docs.factor
View File

@ -38,7 +38,7 @@ HELP: find-in-directories
HELP: find-all-files
{ $values
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
{ "path" "a pathname string" } { "quot" quotation }
{ "paths/f" "a sequence of pathname strings or f" }
}
{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ;

2
basis/io/directories/search/search-tests.factor
View File

@ -5,6 +5,6 @@ IN: io.directories.search.tests
[ t ] [
[
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
current-temporary-directory get t [ ] find-all-files
current-temporary-directory get [ ] find-all-files
] with-unique-directory drop [ natural-sort ] bi@ =
] unit-test

11
basis/io/directories/search/search.factor
View File

@ -51,14 +51,21 @@ PRIVATE>
[ keep and ] curry iterate-directory
] [ drop f ] recover ; inline
: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths/f )
: find-all-files ( path quot: ( obj -- ? ) -- paths/f )
f swap
'[
_ _ _ [ <directory-iterator> ] dip
pusher [ [ f ] compose iterate-directory drop ] dip
] [ drop f ] recover ; inline
ERROR: file-not-found ;
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
'[ _ _ find-file ] attempt-all ;
[
'[ _ _ find-file [ file-not-found ] unless* ] attempt-all
] [
drop f
] recover ;
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
'[ _ _ find-all-files ] map concat ;

4
basis/io/directories/search/windows/windows.factor
View File

@ -7,7 +7,7 @@ IN: io.directories.search.windows
: program-files-directories ( -- array )
program-files program-files-x86 2array harvest ; inline
: find-in-program-files ( base-directory bfs? quot -- path )
[
: find-in-program-files ( base-directory quot -- path )
t swap [
[ program-files-directories ] dip '[ _ append-path ] map
] 2dip find-in-directories ; inline

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