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

basis/alien/c-types/c-types.factor

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

basis/alien/fortran/fortran.factor

@@ -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*
+    >lower fortran>c-types ?at
-    [ nip new-fortran-type ] [ drop misc-type boa ] if ;
+    [ new-fortran-type ] [ misc-type boa ] if ;
 
 : parse-fortran-type ( fortran-type-string/f -- type/f )
     dup [ (parse-fortran-type) ] when ;

basis/bootstrap/image/download/download.factor

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

basis/bootstrap/image/image.factor

@@ -77,20 +77,20 @@ SYMBOL: objects
 
 ! Constants
 
-: image-magic HEX: 0f0e0d0c ; inline
+CONSTANT: image-magic HEX: 0f0e0d0c
-: image-version 4 ; inline
+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
+CONSTANT: data-heap-size-offset 3
-: t-offset              6 ; inline
+CONSTANT: t-offset              6
-: 0-offset              7 ; inline
+CONSTANT: 0-offset              7
-: 1-offset              8 ; inline
+CONSTANT: 1-offset              8
-: -1-offset             9 ; inline
+CONSTANT: -1-offset             9
 
 SYMBOL: sub-primitives
 

basis/cairo/ffi/ffi.factor

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

basis/calendar/calendar.factor

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

basis/checksums/adler-32/adler-32.factor

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

basis/checksums/openssl/openssl-docs.factor

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

basis/checksums/openssl/openssl.factor

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

basis/checksums/sha2/sha2.factor

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

basis/cocoa/application/application.factor

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

basis/cocoa/dialogs/dialogs.factor

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

basis/cocoa/enumeration/enumeration.factor

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

basis/cocoa/messages/messages.factor

@@ -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
+continuations combinators compiler compiler.alien stack-checker kernel
-namespaces make parser quotations sequences strings words
+math namespaces make parser quotations sequences strings words
-cocoa.runtime io macros memoize io.encodings.utf8
+cocoa.runtime io macros memoize io.encodings.utf8 effects libc
-effects libc libc.private parser lexer init core-foundation fry
+libc.private parser lexer init core-foundation fry generalizations
-generalizations specialized-arrays.direct.alien call ;
+specialized-arrays.direct.alien call ;
 IN: cocoa.messages
 
 : 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

basis/cocoa/pasteboard/pasteboard.factor

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

basis/cocoa/runtime/runtime.factor

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

basis/cocoa/subclassing/subclassing.factor

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

basis/cocoa/views/views.factor

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

basis/cocoa/windows/windows.factor

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

basis/colors/colors.factor

@@ -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
+CONSTANT: black        T{ rgba f 0.0   0.0   0.0   1.0  }
-: blue         T{ rgba f 0.0   0.0   1.0   1.0  } ; inline
+CONSTANT: blue         T{ rgba f 0.0   0.0   1.0   1.0  }
-: cyan         T{ rgba f 0     0.941 0.941 1    } ; inline
+CONSTANT: cyan         T{ rgba f 0     0.941 0.941 1    }
-: gray         T{ rgba f 0.6   0.6   0.6   1.0  } ; inline
+CONSTANT: gray         T{ rgba f 0.6   0.6   0.6   1.0  }
-: green        T{ rgba f 0.0   1.0   0.0   1.0  } ; inline
+CONSTANT: green        T{ rgba f 0.0   1.0   0.0   1.0  }
-: light-gray   T{ rgba f 0.95  0.95  0.95  0.95 } ; inline
+CONSTANT: light-gray   T{ rgba f 0.95  0.95  0.95  0.95 }
-: light-purple T{ rgba f 0.8   0.8   1.0   1.0  } ; inline
+CONSTANT: light-purple T{ rgba f 0.8   0.8   1.0   1.0  }
-: magenta      T{ rgba f 0.941 0     0.941 1    } ; inline
+CONSTANT: magenta      T{ rgba f 0.941 0     0.941 1    }
-: orange       T{ rgba f 0.941 0.627 0     1    } ; inline
+CONSTANT: orange       T{ rgba f 0.941 0.627 0     1    }
-: purple       T{ rgba f 0.627 0     0.941 1    } ; inline
+CONSTANT: purple       T{ rgba f 0.627 0     0.941 1    }
-: red          T{ rgba f 1.0   0.0   0.0   1.0  } ; inline
+CONSTANT: red          T{ rgba f 1.0   0.0   0.0   1.0  }
-: white        T{ rgba f 1.0   1.0   1.0   1.0  } ; inline
+CONSTANT: white        T{ rgba f 1.0   1.0   1.0   1.0  }
-: yellow       T{ rgba f 1.0   1.0   0.0   1.0  } ; inline
+CONSTANT: yellow       T{ rgba f 1.0   1.0   0.0   1.0  }

basis/compiler/cfg/debugger/debugger.factor

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

basis/compiler/compiler-docs.factor

@@ -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." } ;

basis/compiler/compiler.factor

@@ -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
+USING: accessors kernel namespaces arrays sequences io words fry
-words fry continuations vocabs assocs dlists definitions math
+continuations vocabs assocs dlists definitions math graphs
-graphs generic combinators deques search-deques io
+generic combinators deques search-deques io stack-checker
-stack-checker stack-checker.state stack-checker.inlining
+stack-checker.state stack-checker.inlining
-compiler.errors compiler.units compiler.tree.builder
+combinators.short-circuit compiler.errors compiler.units
-compiler.tree.optimizer compiler.cfg.builder
+compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.optimizer compiler.cfg.linearization
+compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.two-operand compiler.cfg.linear-scan
+compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
+compiler.cfg.linear-scan compiler.cfg.stack-frame
+compiler.codegen compiler.utilities ;
 IN: compiler
 
 SYMBOL: compile-queue
 SYMBOL: compiled
 
-: queue-compile ( word -- )
+: queue-compile? ( word -- ? )
     {
-        { [ dup "forgotten" word-prop ] [ ] }
+        [ "forgotten" word-prop ]
-        { [ dup compiled get key? ] [ ] }
+        [ compiled get key? ]
-        { [ dup inlined-block? ] [ ] }
+        [ inlined-block? ]
-        { [ dup primitive? ] [ ] }
+        [ primitive? ]
-        [ dup compile-queue get push-front ]
+    } 1|| not ;
-    } cond drop ;
+
+: queue-compile ( word -- )
+    dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
 
 : maybe-compile ( word -- )
     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 -- ? )
+: ripple-up? ( word status -- ? )
-    #! If the word has previously been compiled and had a
+    swap "compiled-status" word-prop [ = not ] keep and ;
-    #! different stack effect, we have to recompile any callers.
-    swap "compiled-effect" word-prop [ = not ] keep and ;
 
-: save-effect ( word effect -- )
+: save-compiled-status ( word status -- )
     [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
-    [ "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 -- )
+: finish ( word -- )
-    [ swap save-effect ]
+    [ +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

basis/compiler/constants/constants.factor

@@ -4,8 +4,8 @@ USING: math kernel layouts system strings ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
-: card-bits 8 ; inline
+CONSTANT: card-bits 8
-: deck-bits 18 ; inline
+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
+CONSTANT: rc-absolute-cell    0
-: rc-absolute         1 ; inline
+CONSTANT: rc-absolute         1
-: rc-relative         2 ; inline
+CONSTANT: rc-relative         2
-: rc-absolute-ppc-2/2 3 ; inline
+CONSTANT: rc-absolute-ppc-2/2 3
-: rc-relative-ppc-2   4 ; inline
+CONSTANT: rc-relative-ppc-2   4
-: rc-relative-ppc-3   5 ; inline
+CONSTANT: rc-relative-ppc-3   5
-: rc-relative-arm-3   6 ; inline
+CONSTANT: rc-relative-arm-3   6
-: rc-indirect-arm     7 ; inline
+CONSTANT: rc-indirect-arm     7
-: rc-indirect-arm-pc  8 ; inline
+CONSTANT: rc-indirect-arm-pc  8
 
 ! Relocation types
-: rt-primitive   0 ; inline
+CONSTANT: rt-primitive   0
-: rt-dlsym       1 ; inline
+CONSTANT: rt-dlsym       1
-: rt-dispatch    2 ; inline
+CONSTANT: rt-dispatch    2
-: rt-xt          3 ; inline
+CONSTANT: rt-xt          3
-: rt-here        4 ; inline
+CONSTANT: rt-here        4
-: rt-label       5 ; inline
+CONSTANT: rt-label       5
-: rt-immediate   6 ; inline
+CONSTANT: rt-immediate   6
-: rt-stack-chain 7 ; inline
+CONSTANT: rt-stack-chain 7
 
 : rc-absolute? ( n -- ? )
     [ rc-absolute-ppc-2/2 = ]

basis/compiler/tests/codegen.factor

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

basis/compiler/tests/curry.factor

@@ -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 -- )
+: foobar ( quot: ( -- ) -- )
-    dup slip swap [ foobar ] [ drop ] if ; inline
+    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

basis/compiler/tests/float.factor

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

basis/compiler/tests/intrinsics.factor

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

basis/compiler/tests/optimizer.factor

@@ -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-2 ( -- value ) f ; foldable
-: constant-fold-3 4 ; 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-4 ( -- value ) f ; foldable
-: constant-fold-5 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
+        [ drop dup midpoint@ head-slice old-binsearch ] if
-    ] if ; inline
+    ] 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
 

basis/compiler/tests/peg-regression-2.factor

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

basis/compiler/tests/simple.factor

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

basis/compiler/tests/tuples.factor

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

basis/compiler/tree/builder/builder-tests.factor

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

basis/compiler/tree/builder/builder.factor

@@ -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 )
     [
         [
             {

basis/compiler/tree/cleanup/cleanup-tests.factor

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

basis/compiler/tree/comparisons/comparisons.factor

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

basis/compiler/tree/debugger/debugger.factor

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

basis/compiler/tree/propagation/info/info.factor

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

basis/compiler/tree/propagation/known-words/known-words.factor

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

basis/compiler/tree/recursive/recursive-tests.factor

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

basis/compression/lzw/lzw.factor

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

basis/core-foundation/core-foundation.factor

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

basis/core-foundation/data/data.factor

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

basis/core-foundation/file-descriptors/file-descriptors.factor

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

basis/core-foundation/fsevents/fsevents.factor

@@ -9,17 +9,17 @@ core-foundation core-foundation.run-loop core-foundation.strings
 core-foundation.time ;
 IN: core-foundation.fsevents
 
-: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
+CONSTANT: kFSEventStreamCreateFlagUseCFTypes 2
-: kFSEventStreamCreateFlagWatchRoot 4 ; inline
+CONSTANT: kFSEventStreamCreateFlagWatchRoot 4
 
-: kFSEventStreamEventFlagMustScanSubDirs 1 ; inline
+CONSTANT: kFSEventStreamEventFlagMustScanSubDirs 1
-: kFSEventStreamEventFlagUserDropped 2 ; inline
+CONSTANT: kFSEventStreamEventFlagUserDropped 2
-: kFSEventStreamEventFlagKernelDropped 4 ; inline
+CONSTANT: kFSEventStreamEventFlagKernelDropped 4
-: kFSEventStreamEventFlagEventIdsWrapped 8 ; inline
+CONSTANT: kFSEventStreamEventFlagEventIdsWrapped 8
-: kFSEventStreamEventFlagHistoryDone 16 ; inline
+CONSTANT: kFSEventStreamEventFlagHistoryDone 16
-: kFSEventStreamEventFlagRootChanged 32 ; inline
+CONSTANT: kFSEventStreamEventFlagRootChanged 32
-: kFSEventStreamEventFlagMount 64 ; inline
+CONSTANT: kFSEventStreamEventFlagMount 64
-: kFSEventStreamEventFlagUnmount 128 ; inline
+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,

basis/core-foundation/run-loop/run-loop.factor

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

basis/core-foundation/strings/strings.factor

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

basis/core-foundation/urls/urls.factor

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

basis/cpu/ppc/ppc.factor

@@ -27,8 +27,8 @@ M: ppc machine-registers
         { double-float-regs T{ range f 0 29 1 } }
     } ;
 
-: scratch-reg 28 ; inline
+CONSTANT: scratch-reg 28
-: fp-scratch-reg 30 ; inline
+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
+CONSTANT: ds-reg 29
-: rs-reg 30 ; inline
+CONSTANT: rs-reg 30
 
 GENERIC: loc-reg ( loc -- reg )
 

basis/db/db.factor

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

basis/db/errors/errors.factor

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

basis/db/errors/postgresql/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/db/errors/postgresql/postgresql-tests.factor

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

basis/db/errors/postgresql/postgresql.factor

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

basis/db/errors/sqlite/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/db/errors/sqlite/sqlite-tests.factor

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

basis/db/errors/sqlite/sqlite.factor

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

basis/db/postgresql/postgresql-tests.factor

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

basis/db/postgresql/postgresql.factor

@@ -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 ;
+nmake accessors random db.queries destructors db.tuples.private
-USE: tools.walker
+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 ;
+

basis/db/sqlite/lib/lib.factor

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

basis/db/sqlite/sqlite-tests.factor

@@ -123,12 +123,8 @@ hi "HELLO" {
     ] with-db
 ] unit-test
 
-[ ] [
+
-    test.db [
+! Test SQLite triggers
-        hi create-table
-        hi drop-table
-    ] with-db
-] unit-test
 
 TUPLE: show id ;
 TUPLE: user username data ;
@@ -144,10 +140,10 @@ show "SHOW" {
 } define-persistent
 
 watch "WATCH" {
-    { "user" "USER" TEXT +not-null+
+    { "user" "USER" TEXT +not-null+ +user-assigned-id+
-        { +foreign-id+ user "USERNAME" } +user-assigned-id+ }
+        { +foreign-id+ user "USERNAME" } }
-    { "show" "SHOW" BIG-INTEGER +not-null+
+    { "show" "SHOW" BIG-INTEGER +not-null+ +user-assigned-id+
-        { +foreign-id+ show "ID" } +user-assigned-id+ }
+        { +foreign-id+ show "ID" } }
 } define-persistent
     
 [ T{ user { username "littledan" } { data "foo" } } ] [
@@ -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

basis/db/sqlite/sqlite.factor

@@ -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"')
+            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.${foreign-table-id} IS NOT NULL
+            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"')
+            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;
+            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"')
+            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.${foreign-table-id} IS NOT NULL
+            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"')
+            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;
+            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 ( -- )
+: create-db-triggers ( sql-specs -- )
-    drop-insert-trigger sqlite-trigger,
+    [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
-    drop-update-trigger sqlite-trigger,
+    [
-    delete-cascade? [
+        [ class>> db-table-name "db-table" set ]
-        drop-delete-trigger-cascade sqlite-trigger,
-    ] [
-        drop-delete-trigger-restrict sqlite-trigger,
-    ] if ;
-
-: db-triggers ( sql-specs word -- )
-    '[
-        [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
         [
-            [ 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
-                    [ second db-table-name "foreign-table-name" set ]
+                create-sqlite-triggers
-                    [ third "foreign-table-id" set ] bi
+            ] each
-                    _ execute
+        ] bi
-                ] each
+    ] each ;
-            ] tri
-        ] each
-    ] call ;
 
 : 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% ] query-make ;
-        [ nip "drop table " 0% 0% ";" 0% ]
-        [ drop \ drop-sqlite-triggers db-triggers ] 2bi
-    ] 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 ;

basis/db/tester/tester.factor

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

basis/db/tuples/tuples-tests.factor

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

basis/db/tuples/tuples.factor

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

basis/db/types/types.factor

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

basis/editors/editpadlite/editpadlite.factor

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

basis/editors/editpadpro/editpadpro.factor

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

basis/editors/editplus/editplus.factor

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

basis/editors/emacs/emacs.factor

@@ -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 ,
+        { [ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
-        os windows? [ "--no-wait" , ] unless
+        "--no-wait" ,
-        "+" swap number>string append ,
+        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

basis/editors/emacs/windows/windows.factor

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

basis/editors/emeditor/emeditor.factor

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

basis/editors/etexteditor/etexteditor.factor

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

basis/editors/gvim/windows/windows.factor

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

basis/editors/notepadpp/notepadpp.factor

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

basis/editors/scite/scite.factor

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

basis/editors/ted-notepad/ted-notepad.factor

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

basis/editors/textpad/textpad.factor

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

basis/editors/ultraedit/ultraedit.factor

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

basis/editors/wordpad/wordpad.factor

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

basis/farkup/farkup.factor

@@ -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' )
     {

basis/functors/functors.factor

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

basis/furnace/actions/actions.factor

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

basis/furnace/alloy/alloy.factor

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

basis/furnace/asides/asides.factor

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

basis/furnace/auth/login/login.factor

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

basis/furnace/auth/providers/null/null.factor

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

basis/furnace/conversations/conversations.factor

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

basis/furnace/sessions/sessions.factor

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

basis/furnace/utilities/utilities.factor

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

basis/help/topics/topics.factor

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

basis/hints/hints.factor

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

basis/html/templates/chloe/syntax/syntax.factor

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

basis/images/tiff/tiff.factor

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

basis/io/backend/unix/unix.factor

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

basis/io/directories/search/search-docs.factor

@@ -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." } ;

basis/io/directories/search/search-tests.factor

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

basis/io/directories/search/search.factor

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

basis/io/directories/search/windows/windows.factor

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