Merge branch 'master' of git://factorcode.org/git/factor
commit
91652c706b
|
@ -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>
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 )
|
||||
{
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 )
|
||||
{
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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 -- )
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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? ;
|
||||
|
|
|
@ -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 ) ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 )
|
||||
{
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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?
|
||||
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 = ]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
[
|
||||
[
|
||||
{
|
||||
|
|
|
@ -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
|
|
@ -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 )
|
||||
{
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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<=
|
||||
|
|
|
@ -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
|
||||
|
||||
{
|
||||
|
|
|
@ -87,7 +87,7 @@ compiler.tree.combinators ;
|
|||
] contains-node?
|
||||
] unit-test
|
||||
|
||||
: blah f ;
|
||||
: blah ( -- value ) f ;
|
||||
|
||||
DEFER: a
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ) ;
|
||||
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -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
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 -- )
|
||||
{
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 -- )
|
||||
[
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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,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|| ;
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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*
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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' )
|
||||
{
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -64,7 +64,7 @@ SYMBOL: capabilities
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: flashed-variables { description capabilities } ;
|
||||
CONSTANT: flashed-variables { description capabilities }
|
||||
|
||||
: login-failed ( -- * )
|
||||
"invalid username or password" validation-error
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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?>> [
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 = ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
Loading…
Reference in New Issue