diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a44b5cf2b6..c3fd41e689 100755 --- a/basis/alien/c-types/c-types.factor +++ b/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" - } ; + } [ diff --git a/basis/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor index f9b7b56779..5bfc5f7ccc 100644 --- a/basis/bootstrap/image/download/download.factor +++ b/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 diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index d29a3fb097..c2daa05374 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/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 ; -: 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 ) diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index 4bc7a7964a..58748b7c29 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/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 diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index ab2b6375a9..19d83b86d7 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -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 diff --git a/basis/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor index 13f6f0b7d6..84a1ad46a3 100644 --- a/basis/cocoa/dialogs/dialogs.factor +++ b/basis/cocoa/dialogs/dialogs.factor @@ -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 ) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index ce66467203..9a1bebd38f 100644 --- a/basis/cocoa/messages/messages.factor +++ b/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 -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 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 diff --git a/basis/cocoa/pasteboard/pasteboard.factor b/basis/cocoa/pasteboard/pasteboard.factor index 888f5452e2..1a21b338be 100644 --- a/basis/cocoa/pasteboard/pasteboard.factor +++ b/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? ; diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 1a741b789f..7817d0006c 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -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 ) ; diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index be53364185..0896312670 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/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 [ - "cdecl" swap 4array % \ alien-callback , - ] [ ] make define-temp ; + [ [ encode-types ] 2keep ] dip + '[ _ _ "cdecl" _ alien-callback ] + (( -- callback )) define-temp ; : prepare-methods ( methods -- methods ) [ diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index e74e912202..4bb6468fa6 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -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 USE: opengl.gl USE: alien.syntax -: NSOpenGLCPSwapInterval 222 ; +CONSTANT: NSOpenGLCPSwapInterval 222 LIBRARY: OpenGL diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index ba58e60a4a..6d0a8f8c8e 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/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? diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 1c6e7b796e..9169e9e0fa 100644 --- a/basis/compiler/compiler-docs.factor +++ b/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." } ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index f2f4e7aa9e..d6da95408d 100644 --- a/basis/compiler/compiler.factor +++ b/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 -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 ) [ compile-queue set diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 78e95ffb91..2e02e5476c 100644 --- a/basis/compiler/tests/codegen.factor +++ b/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 diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index 1857baf503..2d1f15b9a8 100644 --- a/basis/compiler/tests/curry.factor +++ b/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 -- ) - 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 diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 81ab750305..b439b5f6a4 100644 --- a/basis/compiler/tests/float.factor +++ b/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 diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index df5f484952..6c6d580c87 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/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. diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index c5bbe4a6c3..b5cb0ddbdb 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/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-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 @@ -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 diff --git a/basis/compiler/tests/peg-regression-2.factor b/basis/compiler/tests/peg-regression-2.factor new file mode 100644 index 0000000000..1efadba3aa --- /dev/null +++ b/basis/compiler/tests/peg-regression-2.factor @@ -0,0 +1,15 @@ +IN: compiler.tests +USING: peg.ebnf strings tools.test ; + +GENERIC: ( times -- term' ) +M: string ; + +EBNF: parse-regexp + +Times = .* => [[ "foo" ]] + +Regexp = Times:t => [[ t ]] + +;EBNF + +[ "foo" ] [ "a" parse-regexp ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index a6d6c5dfb9..d53b864b06 100644 --- a/basis/compiler/tests/simple.factor +++ b/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 diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index 602b438432..caa214b70c 100644 --- a/basis/compiler/tests/tuples.factor +++ b/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 ; diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index d758e2a34d..4982a3986c 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/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 diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index b715223445..4cb7650b1d 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/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 ) [ [ { diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 751a335a13..54f8aaf20e 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/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 diff --git a/basis/compiler/tree/comparisons/comparisons.factor b/basis/compiler/tree/comparisons/comparisons.factor index 5242302411..5f4b1e8dab 100644 --- a/basis/compiler/tree/comparisons/comparisons.factor +++ b/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 ) { diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 9f2cc0536e..188dcdb935 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/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 diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index b1f9406092..d548d58bc6 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/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 diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index c3a969a325..50c17dc6fd 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -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, diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index eea30a3040..50ee938659 100755 --- a/basis/farkup/farkup.factor +++ b/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' ) { diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 14151692f0..0b9c9caa45 100644 --- a/basis/functors/functors.factor +++ b/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 diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 97cb73c9cb..166d2a88a2 100644 --- a/basis/furnace/actions/actions.factor +++ b/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 diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor index 0fe80427b9..dc280c1e44 100644 --- a/basis/furnace/alloy/alloy.factor +++ b/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 diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor index 7489d19f94..ecf6d0a628 100644 --- a/basis/furnace/asides/asides.factor +++ b/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 ; diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index 0ceafa7f86..915ae1c224 100644 --- a/basis/furnace/auth/login/login.factor +++ b/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 diff --git a/basis/furnace/auth/providers/null/null.factor b/basis/furnace/auth/providers/null/null.factor index 39ea812ae7..0fab3c5b09 100644 --- a/basis/furnace/auth/providers/null/null.factor +++ b/basis/furnace/auth/providers/null/null.factor @@ -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 ; diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor index 266958c8a4..bbb84e2f05 100644 --- a/basis/furnace/conversations/conversations.factor +++ b/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 ; diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index 52e705c153..3eb7a11215 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/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?>> [ diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 4fc68f7735..c0cb7dbced 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -89,7 +89,7 @@ M: object modify-form drop f ; [XML 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 ) diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index faf8bed66b..9e7079023d 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/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 = ; diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index f5e6426859..f210180517 100644 --- a/basis/io/backend/unix/unix.factor +++ b/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 ) diff --git a/basis/io/encodings/8-bit/8-bit.factor b/basis/io/encodings/8-bit/8-bit.factor index bad2d9fd82..9ef2b07322 100644 --- a/basis/io/encodings/8-bit/8-bit.factor +++ b/basis/io/encodings/8-bit/8-bit.factor @@ -4,12 +4,12 @@ USING: math.parser arrays io.encodings sequences kernel assocs hashtables io.encodings.ascii generic parser classes.tuple words words.symbol io io.files splitting namespaces math compiler.units accessors classes.singleton classes.mixin -io.encodings.iana ; +io.encodings.iana fry ; IN: io.encodings.8-bit ch ( assoc -- array ) 256 replacement-char - [ [ swapd set-nth ] curry assoc-each ] keep ; + [ '[ swap _ set-nth ] assoc-each ] keep ; : ch>byte ( assoc -- newassoc ) [ swap ] assoc-map >hashtable ; diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 618dba544c..7dced852fd 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -63,7 +63,7 @@ SYMBOL: log-files dup values [ try-dispose ] each clear-assoc ; -: keep-logs 10 ; +CONSTANT: keep-logs 10 : ?delete-file ( path -- ) dup exists? [ delete-file ] [ drop ] if ; diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 4fba7efba3..21a91e567d 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel sequences words effects combinators assocs definitions quotations namespaces memoize accessors ; @@ -7,7 +7,7 @@ IN: macros > 1 ; + stack-effect in>> 1 ; PRIVATE> diff --git a/basis/math/quaternions/quaternions.factor b/basis/math/quaternions/quaternions.factor index bc6da9f564..f2c2c6d226 100755 --- a/basis/math/quaternions/quaternions.factor +++ b/basis/math/quaternions/quaternions.factor @@ -45,13 +45,13 @@ PRIVATE> first2 [ imaginary-part ] dip >rect 3array ; ! Zero -: q0 { 0 0 } ; +CONSTANT: q0 { 0 0 } ! Units -: q1 { 1 0 } ; -: qi { C{ 0 1 } 0 } ; -: qj { 0 1 } ; -: qk { 0 C{ 0 1 } } ; +CONSTANT: q1 { 1 0 } +CONSTANT: qi { C{ 0 1 } 0 } +CONSTANT: qj { 0 1 } +CONSTANT: qk { 0 C{ 0 1 } } ! Euler angles diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 7ee56866ce..03549d9b80 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel memoize tools.test parser generalizations prettyprint io.streams.string sequences eval ; @@ -17,6 +17,10 @@ MEMO: see-test ( a -- b ) reverse ; [ [ \ see-test see ] with-string-writer ] unit-test -[ ] [ "IN: memoize.tests : fib ;" eval ] unit-test +[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test + +[ sq ] (( a -- b )) memoize-quot "q" set + +[ 9 ] [ 3 "q" get call ] unit-test diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 7b8c30c534..3bc573dff5 100644 --- a/basis/memoize/memoize.factor +++ b/basis/memoize/memoize.factor @@ -1,47 +1,45 @@ -! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel hashtables sequences arrays words namespaces make parser math assocs effects definitions quotations summary -accessors ; +accessors fry ; IN: memoize -: packer ( n -- quot ) - { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ; - -: unpacker ( n -- quot ) - { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ; - -: #in ( word -- n ) - stack-effect in>> length ; - -: #out ( word -- n ) - stack-effect out>> length ; - -: pack/unpack ( quot word -- newquot ) - [ dup #in unpacker % swap % #out packer % ] [ ] make ; - -: make-memoizer ( quot word -- quot ) - [ - [ #in packer % ] keep - [ "memoize" word-prop , ] keep - [ pack/unpack , ] keep - \ cache , - #out unpacker % - ] [ ] make ; - ERROR: too-many-arguments ; M: too-many-arguments summary drop "There must be no more than 4 input and 4 output arguments" ; -: check-memoized ( word -- ) - [ #in ] [ #out ] bi [ 4 > ] either? [ too-many-arguments ] when ; +> packer ] [ out>> unpacker ] bi surround ; + +: unpack/pack ( quot effect -- newquot ) + [ in>> unpacker ] [ out>> packer ] bi surround ; + +: check-memoized ( effect -- ) + [ in>> ] [ out>> ] bi [ length 4 > ] either? [ too-many-arguments ] when ; + +: make-memoizer ( table quot effect -- quot ) + [ check-memoized ] keep + [ unpack/pack '[ _ _ cache ] ] keep + pack/unpack ; + +PRIVATE> : define-memoized ( word quot -- ) - over check-memoized - 2dup "memo-quot" set-word-prop - over H{ } clone "memoize" set-word-prop - over make-memoizer define ; + [ H{ } clone ] dip + [ pick stack-effect make-memoizer define ] + [ nip "memo-quot" set-word-prop ] + [ drop "memoize" set-word-prop ] + 3tri ; : MEMO: (:) define-memoized ; parsing @@ -57,11 +55,10 @@ M: memoized reset-word bi ; : memoize-quot ( quot effect -- memo-quot ) - gensym swap dupd "declared-effect" set-word-prop - dup rot define-memoized 1quotation ; + [ H{ } clone ] 2dip make-memoizer ; : reset-memoized ( word -- ) "memoize" word-prop clear-assoc ; : invalidate-memoized ( inputs... word -- ) - [ #in packer call ] [ "memoize" word-prop delete-at ] bi ; + [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ; diff --git a/basis/none/none.factor b/basis/none/none.factor index 66a0de8328..77941479aa 100644 --- a/basis/none/none.factor +++ b/basis/none/none.factor @@ -1,6 +1,6 @@ ! Just a dummy shell for the -run switch... IN: none -: none ; +: none ( -- ) ; MAIN: none diff --git a/basis/opengl/glu/glu.factor b/basis/opengl/glu/glu.factor index da19ac52fc..d603724a55 100644 --- a/basis/opengl/glu/glu.factor +++ b/basis/opengl/glu/glu.factor @@ -11,183 +11,183 @@ TYPEDEF: void* GLubyte* TYPEDEF: void* GLUfuncptr ! StringName -: GLU_VERSION 100800 ; -: GLU_EXTENSIONS 100801 ; +CONSTANT: GLU_VERSION 100800 +CONSTANT: GLU_EXTENSIONS 100801 ! ErrorCode -: GLU_INVALID_ENUM 100900 ; -: GLU_INVALID_VALUE 100901 ; -: GLU_OUT_OF_MEMORY 100902 ; -: GLU_INCOMPATIBLE_GL_VERSION 100903 ; -: GLU_INVALID_OPERATION 100904 ; +CONSTANT: GLU_INVALID_ENUM 100900 +CONSTANT: GLU_INVALID_VALUE 100901 +CONSTANT: GLU_OUT_OF_MEMORY 100902 +CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903 +CONSTANT: GLU_INVALID_OPERATION 100904 ! NurbsDisplay -: GLU_OUTLINE_POLYGON 100240 ; -: GLU_OUTLINE_PATCH 100241 ; +CONSTANT: GLU_OUTLINE_POLYGON 100240 +CONSTANT: GLU_OUTLINE_PATCH 100241 ! NurbsCallback -: GLU_NURBS_ERROR 100103 ; -: GLU_ERROR 100103 ; -: GLU_NURBS_BEGIN 100164 ; -: GLU_NURBS_BEGIN_EXT 100164 ; -: GLU_NURBS_VERTEX 100165 ; -: GLU_NURBS_VERTEX_EXT 100165 ; -: GLU_NURBS_NORMAL 100166 ; -: GLU_NURBS_NORMAL_EXT 100166 ; -: GLU_NURBS_COLOR 100167 ; -: GLU_NURBS_COLOR_EXT 100167 ; -: GLU_NURBS_TEXTURE_COORD 100168 ; -: GLU_NURBS_TEX_COORD_EXT 100168 ; -: GLU_NURBS_END 100169 ; -: GLU_NURBS_END_EXT 100169 ; -: GLU_NURBS_BEGIN_DATA 100170 ; -: GLU_NURBS_BEGIN_DATA_EXT 100170 ; -: GLU_NURBS_VERTEX_DATA 100171 ; -: GLU_NURBS_VERTEX_DATA_EXT 100171 ; -: GLU_NURBS_NORMAL_DATA 100172 ; -: GLU_NURBS_NORMAL_DATA_EXT 100172 ; -: GLU_NURBS_COLOR_DATA 100173 ; -: GLU_NURBS_COLOR_DATA_EXT 100173 ; -: GLU_NURBS_TEXTURE_COORD_DATA 100174 ; -: GLU_NURBS_TEX_COORD_DATA_EXT 100174 ; -: GLU_NURBS_END_DATA 100175 ; -: GLU_NURBS_END_DATA_EXT 100175 ; +CONSTANT: GLU_NURBS_ERROR 100103 +CONSTANT: GLU_ERROR 100103 +CONSTANT: GLU_NURBS_BEGIN 100164 +CONSTANT: GLU_NURBS_BEGIN_EXT 100164 +CONSTANT: GLU_NURBS_VERTEX 100165 +CONSTANT: GLU_NURBS_VERTEX_EXT 100165 +CONSTANT: GLU_NURBS_NORMAL 100166 +CONSTANT: GLU_NURBS_NORMAL_EXT 100166 +CONSTANT: GLU_NURBS_COLOR 100167 +CONSTANT: GLU_NURBS_COLOR_EXT 100167 +CONSTANT: GLU_NURBS_TEXTURE_COORD 100168 +CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168 +CONSTANT: GLU_NURBS_END 100169 +CONSTANT: GLU_NURBS_END_EXT 100169 +CONSTANT: GLU_NURBS_BEGIN_DATA 100170 +CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170 +CONSTANT: GLU_NURBS_VERTEX_DATA 100171 +CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171 +CONSTANT: GLU_NURBS_NORMAL_DATA 100172 +CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172 +CONSTANT: GLU_NURBS_COLOR_DATA 100173 +CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173 +CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174 +CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174 +CONSTANT: GLU_NURBS_END_DATA 100175 +CONSTANT: GLU_NURBS_END_DATA_EXT 100175 ! NurbsError -: GLU_NURBS_ERROR1 100251 ; -: GLU_NURBS_ERROR2 100252 ; -: GLU_NURBS_ERROR3 100253 ; -: GLU_NURBS_ERROR4 100254 ; -: GLU_NURBS_ERROR5 100255 ; -: GLU_NURBS_ERROR6 100256 ; -: GLU_NURBS_ERROR7 100257 ; -: GLU_NURBS_ERROR8 100258 ; -: GLU_NURBS_ERROR9 100259 ; -: GLU_NURBS_ERROR10 100260 ; -: GLU_NURBS_ERROR11 100261 ; -: GLU_NURBS_ERROR12 100262 ; -: GLU_NURBS_ERROR13 100263 ; -: GLU_NURBS_ERROR14 100264 ; -: GLU_NURBS_ERROR15 100265 ; -: GLU_NURBS_ERROR16 100266 ; -: GLU_NURBS_ERROR17 100267 ; -: GLU_NURBS_ERROR18 100268 ; -: GLU_NURBS_ERROR19 100269 ; -: GLU_NURBS_ERROR20 100270 ; -: GLU_NURBS_ERROR21 100271 ; -: GLU_NURBS_ERROR22 100272 ; -: GLU_NURBS_ERROR23 100273 ; -: GLU_NURBS_ERROR24 100274 ; -: GLU_NURBS_ERROR25 100275 ; -: GLU_NURBS_ERROR26 100276 ; -: GLU_NURBS_ERROR27 100277 ; -: GLU_NURBS_ERROR28 100278 ; -: GLU_NURBS_ERROR29 100279 ; -: GLU_NURBS_ERROR30 100280 ; -: GLU_NURBS_ERROR31 100281 ; -: GLU_NURBS_ERROR32 100282 ; -: GLU_NURBS_ERROR33 100283 ; -: GLU_NURBS_ERROR34 100284 ; -: GLU_NURBS_ERROR35 100285 ; -: GLU_NURBS_ERROR36 100286 ; -: GLU_NURBS_ERROR37 100287 ; +CONSTANT: GLU_NURBS_ERROR1 100251 +CONSTANT: GLU_NURBS_ERROR2 100252 +CONSTANT: GLU_NURBS_ERROR3 100253 +CONSTANT: GLU_NURBS_ERROR4 100254 +CONSTANT: GLU_NURBS_ERROR5 100255 +CONSTANT: GLU_NURBS_ERROR6 100256 +CONSTANT: GLU_NURBS_ERROR7 100257 +CONSTANT: GLU_NURBS_ERROR8 100258 +CONSTANT: GLU_NURBS_ERROR9 100259 +CONSTANT: GLU_NURBS_ERROR10 100260 +CONSTANT: GLU_NURBS_ERROR11 100261 +CONSTANT: GLU_NURBS_ERROR12 100262 +CONSTANT: GLU_NURBS_ERROR13 100263 +CONSTANT: GLU_NURBS_ERROR14 100264 +CONSTANT: GLU_NURBS_ERROR15 100265 +CONSTANT: GLU_NURBS_ERROR16 100266 +CONSTANT: GLU_NURBS_ERROR17 100267 +CONSTANT: GLU_NURBS_ERROR18 100268 +CONSTANT: GLU_NURBS_ERROR19 100269 +CONSTANT: GLU_NURBS_ERROR20 100270 +CONSTANT: GLU_NURBS_ERROR21 100271 +CONSTANT: GLU_NURBS_ERROR22 100272 +CONSTANT: GLU_NURBS_ERROR23 100273 +CONSTANT: GLU_NURBS_ERROR24 100274 +CONSTANT: GLU_NURBS_ERROR25 100275 +CONSTANT: GLU_NURBS_ERROR26 100276 +CONSTANT: GLU_NURBS_ERROR27 100277 +CONSTANT: GLU_NURBS_ERROR28 100278 +CONSTANT: GLU_NURBS_ERROR29 100279 +CONSTANT: GLU_NURBS_ERROR30 100280 +CONSTANT: GLU_NURBS_ERROR31 100281 +CONSTANT: GLU_NURBS_ERROR32 100282 +CONSTANT: GLU_NURBS_ERROR33 100283 +CONSTANT: GLU_NURBS_ERROR34 100284 +CONSTANT: GLU_NURBS_ERROR35 100285 +CONSTANT: GLU_NURBS_ERROR36 100286 +CONSTANT: GLU_NURBS_ERROR37 100287 ! NurbsProperty -: GLU_AUTO_LOAD_MATRIX 100200 ; -: GLU_CULLING 100201 ; -: GLU_SAMPLING_TOLERANCE 100203 ; -: GLU_DISPLAY_MODE 100204 ; -: GLU_PARAMETRIC_TOLERANCE 100202 ; -: GLU_SAMPLING_METHOD 100205 ; -: GLU_U_STEP 100206 ; -: GLU_V_STEP 100207 ; -: GLU_NURBS_MODE 100160 ; -: GLU_NURBS_MODE_EXT 100160 ; -: GLU_NURBS_TESSELLATOR 100161 ; -: GLU_NURBS_TESSELLATOR_EXT 100161 ; -: GLU_NURBS_RENDERER 100162 ; -: GLU_NURBS_RENDERER_EXT 100162 ; +CONSTANT: GLU_AUTO_LOAD_MATRIX 100200 +CONSTANT: GLU_CULLING 100201 +CONSTANT: GLU_SAMPLING_TOLERANCE 100203 +CONSTANT: GLU_DISPLAY_MODE 100204 +CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202 +CONSTANT: GLU_SAMPLING_METHOD 100205 +CONSTANT: GLU_U_STEP 100206 +CONSTANT: GLU_V_STEP 100207 +CONSTANT: GLU_NURBS_MODE 100160 +CONSTANT: GLU_NURBS_MODE_EXT 100160 +CONSTANT: GLU_NURBS_TESSELLATOR 100161 +CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161 +CONSTANT: GLU_NURBS_RENDERER 100162 +CONSTANT: GLU_NURBS_RENDERER_EXT 100162 ! NurbsSampling -: GLU_OBJECT_PARAMETRIC_ERROR 100208 ; -: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208 ; -: GLU_OBJECT_PATH_LENGTH 100209 ; -: GLU_OBJECT_PATH_LENGTH_EXT 100209 ; -: GLU_PATH_LENGTH 100215 ; -: GLU_PARAMETRIC_ERROR 100216 ; -: GLU_DOMAIN_DISTANCE 100217 ; +CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208 +CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208 +CONSTANT: GLU_OBJECT_PATH_LENGTH 100209 +CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209 +CONSTANT: GLU_PATH_LENGTH 100215 +CONSTANT: GLU_PARAMETRIC_ERROR 100216 +CONSTANT: GLU_DOMAIN_DISTANCE 100217 ! NurbsTrim -: GLU_MAP1_TRIM_2 100210 ; -: GLU_MAP1_TRIM_3 100211 ; +CONSTANT: GLU_MAP1_TRIM_2 100210 +CONSTANT: GLU_MAP1_TRIM_3 100211 ! QuadricDrawStyle -: GLU_POINT 100010 ; -: GLU_LINE 100011 ; -: GLU_FILL 100012 ; -: GLU_SILHOUETTE 100013 ; +CONSTANT: GLU_POINT 100010 +CONSTANT: GLU_LINE 100011 +CONSTANT: GLU_FILL 100012 +CONSTANT: GLU_SILHOUETTE 100013 ! QuadricNormal -: GLU_SMOOTH 100000 ; -: GLU_FLAT 100001 ; -: GLU_NONE 100002 ; +CONSTANT: GLU_SMOOTH 100000 +CONSTANT: GLU_FLAT 100001 +CONSTANT: GLU_NONE 100002 ! QuadricOrientation -: GLU_OUTSIDE 100020 ; -: GLU_INSIDE 100021 ; +CONSTANT: GLU_OUTSIDE 100020 +CONSTANT: GLU_INSIDE 100021 ! TessCallback -: GLU_TESS_BEGIN 100100 ; -: GLU_BEGIN 100100 ; -: GLU_TESS_VERTEX 100101 ; -: GLU_VERTEX 100101 ; -: GLU_TESS_END 100102 ; -: GLU_END 100102 ; -: GLU_TESS_ERROR 100103 ; -: GLU_TESS_EDGE_FLAG 100104 ; -: GLU_EDGE_FLAG 100104 ; -: GLU_TESS_COMBINE 100105 ; -: GLU_TESS_BEGIN_DATA 100106 ; -: GLU_TESS_VERTEX_DATA 100107 ; -: GLU_TESS_END_DATA 100108 ; -: GLU_TESS_ERROR_DATA 100109 ; -: GLU_TESS_EDGE_FLAG_DATA 100110 ; -: GLU_TESS_COMBINE_DATA 100111 ; +CONSTANT: GLU_TESS_BEGIN 100100 +CONSTANT: GLU_BEGIN 100100 +CONSTANT: GLU_TESS_VERTEX 100101 +CONSTANT: GLU_VERTEX 100101 +CONSTANT: GLU_TESS_END 100102 +CONSTANT: GLU_END 100102 +CONSTANT: GLU_TESS_ERROR 100103 +CONSTANT: GLU_TESS_EDGE_FLAG 100104 +CONSTANT: GLU_EDGE_FLAG 100104 +CONSTANT: GLU_TESS_COMBINE 100105 +CONSTANT: GLU_TESS_BEGIN_DATA 100106 +CONSTANT: GLU_TESS_VERTEX_DATA 100107 +CONSTANT: GLU_TESS_END_DATA 100108 +CONSTANT: GLU_TESS_ERROR_DATA 100109 +CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110 +CONSTANT: GLU_TESS_COMBINE_DATA 100111 ! TessContour -: GLU_CW 100120 ; -: GLU_CCW 100121 ; -: GLU_INTERIOR 100122 ; -: GLU_EXTERIOR 100123 ; -: GLU_UNKNOWN 100124 ; +CONSTANT: GLU_CW 100120 +CONSTANT: GLU_CCW 100121 +CONSTANT: GLU_INTERIOR 100122 +CONSTANT: GLU_EXTERIOR 100123 +CONSTANT: GLU_UNKNOWN 100124 ! TessProperty -: GLU_TESS_WINDING_RULE 100140 ; -: GLU_TESS_BOUNDARY_ONLY 100141 ; -: GLU_TESS_TOLERANCE 100142 ; +CONSTANT: GLU_TESS_WINDING_RULE 100140 +CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141 +CONSTANT: GLU_TESS_TOLERANCE 100142 ! TessError -: GLU_TESS_ERROR1 100151 ; -: GLU_TESS_ERROR2 100152 ; -: GLU_TESS_ERROR3 100153 ; -: GLU_TESS_ERROR4 100154 ; -: GLU_TESS_ERROR5 100155 ; -: GLU_TESS_ERROR6 100156 ; -: GLU_TESS_ERROR7 100157 ; -: GLU_TESS_ERROR8 100158 ; -: GLU_TESS_MISSING_BEGIN_POLYGON 100151 ; -: GLU_TESS_MISSING_BEGIN_CONTOUR 100152 ; -: GLU_TESS_MISSING_END_POLYGON 100153 ; -: GLU_TESS_MISSING_END_CONTOUR 100154 ; -: GLU_TESS_COORD_TOO_LARGE 100155 ; -: GLU_TESS_NEED_COMBINE_CALLBACK 100156 ; +CONSTANT: GLU_TESS_ERROR1 100151 +CONSTANT: GLU_TESS_ERROR2 100152 +CONSTANT: GLU_TESS_ERROR3 100153 +CONSTANT: GLU_TESS_ERROR4 100154 +CONSTANT: GLU_TESS_ERROR5 100155 +CONSTANT: GLU_TESS_ERROR6 100156 +CONSTANT: GLU_TESS_ERROR7 100157 +CONSTANT: GLU_TESS_ERROR8 100158 +CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151 +CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152 +CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153 +CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154 +CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155 +CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156 ! TessWinding -: GLU_TESS_WINDING_ODD 100130 ; -: GLU_TESS_WINDING_NONZERO 100131 ; -: GLU_TESS_WINDING_POSITIVE 100132 ; -: GLU_TESS_WINDING_NEGATIVE 100133 ; -: GLU_TESS_WINDING_ABS_GEQ_TWO 100134 ; +CONSTANT: GLU_TESS_WINDING_ODD 100130 +CONSTANT: GLU_TESS_WINDING_NONZERO 100131 +CONSTANT: GLU_TESS_WINDING_POSITIVE 100132 +CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133 +CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134 LIBRARY: glu diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index 3204b83bbb..9cbed1f752 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/basis/openssl/libcrypto/libcrypto.factor @@ -99,7 +99,7 @@ FUNCTION: void* BIO_f_buffer ( ) ; ! evp.h ! =============================================== -: EVP_MAX_MD_SIZE 64 ; +CONSTANT: EVP_MAX_MD_SIZE 64 C-STRUCT: EVP_MD_CTX { "EVP_MD*" "digest" } diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index a9fb366812..aadbbaff16 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -7,12 +7,12 @@ IN: peg.parsers TUPLE: just-parser p1 ; -: just-pattern +CONSTANT: just-pattern [ execute dup [ dup remaining>> empty? [ drop f ] unless ] when - ] ; + ] M: just-parser (compile) ( parser -- quot ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index b08bdd8436..3c298bdfed 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -124,18 +124,13 @@ M: object apply-object push-literal ; : undo-infer ( -- ) recorded get [ f "inferred-effect" set-word-prop ] each ; -: consume/produce ( effect quot -- ) - #! quot is ( inputs outputs -- ) - [ - [ - [ in>> length consume-d ] - [ out>> length produce-d ] - bi - ] dip call - ] [ - drop - terminated?>> [ terminate ] when - ] 2bi ; inline +: (consume/produce) ( effect -- inputs outputs ) + [ in>> length consume-d ] [ out>> length produce-d ] bi ; + +: consume/produce ( effect quot: ( inputs outputs -- ) -- ) + '[ (consume/produce) @ ] + [ terminated?>> [ terminate ] when ] + bi ; inline : infer-word-def ( word -- ) [ specialized-def ] [ add-recursive-state ] bi infer-quot ; @@ -143,30 +138,18 @@ M: object apply-object push-literal ; : end-infer ( -- ) meta-d clone #return, ; -: effect-required? ( word -- ? ) - { - { [ dup deferred? ] [ drop f ] } - { [ dup crossref? not ] [ drop f ] } - [ def>> [ word? ] any? ] - } cond ; - -: ?missing-effect ( word -- ) - dup effect-required? - [ missing-effect inference-error ] [ drop ] if ; +: required-stack-effect ( word -- effect ) + dup stack-effect [ ] [ missing-effect inference-error ] ?if ; : check-effect ( word effect -- ) - over stack-effect { - { [ dup not ] [ 2drop ?missing-effect ] } - { [ 2dup effect<= ] [ 3drop ] } - [ effect-error ] - } cond ; + over required-stack-effect 2dup effect<= + [ 3drop ] [ effect-error ] if ; : finish-word ( word -- ) - current-effect - [ check-effect ] - [ drop recorded get push ] - [ "inferred-effect" set-word-prop ] - 2tri ; + [ current-effect check-effect ] + [ recorded get push ] + [ t "inferred-effect" set-word-prop ] + tri ; : cannot-infer-effect ( word -- * ) "cannot-infer" word-prop throw ; @@ -183,22 +166,20 @@ M: object apply-object push-literal ; dependencies off generic-dependencies off [ infer-word-def end-infer ] - [ finish-word current-effect ] - bi + [ finish-word ] + [ stack-effect ] + tri ] with-scope ] maybe-cannot-infer ; : apply-word/effect ( word effect -- ) swap '[ _ #call, ] consume/produce ; -: required-stack-effect ( word -- effect ) - dup stack-effect [ ] [ \ missing-effect inference-error ] ?if ; - : call-recursive-word ( word -- ) dup required-stack-effect apply-word/effect ; : cached-infer ( word -- ) - dup "inferred-effect" word-prop apply-word/effect ; + dup stack-effect apply-word/effect ; : with-infer ( quot -- effect visitor ) [ diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 56aebb20e7..4ac9d802ed 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -319,12 +319,18 @@ M: object infer-call* \ fixnum/i { fixnum fixnum } { integer } define-primitive \ fixnum/i make-foldable +\ fixnum/i-fast { fixnum fixnum } { fixnum } define-primitive +\ fixnum/i-fast make-foldable + \ fixnum-mod { fixnum fixnum } { fixnum } define-primitive \ fixnum-mod make-foldable \ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive \ fixnum/mod make-foldable +\ fixnum/mod-fast { fixnum fixnum } { fixnum fixnum } define-primitive +\ fixnum/mod-fast make-foldable + \ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive \ fixnum-bitand make-foldable diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 305ef0cca3..8556167009 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -118,7 +118,7 @@ DEFER: stop [ ] while drop ; -: start ( namestack thread -- ) +: start ( namestack thread -- * ) [ set-self set-namestack diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index 1d9761e885..63c8393b51 100644 --- a/basis/tools/deploy/config/config.factor +++ b/basis/tools/deploy/config/config.factor @@ -14,12 +14,12 @@ SYMBOL: deploy-threads? SYMBOL: deploy-io -: deploy-io-options +CONSTANT: deploy-io-options { { 1 "Level 1 - No input/output" } { 2 "Level 2 - Basic ANSI C streams" } { 3 "Level 3 - Non-blocking streams and networking" } - } ; + } : strip-io? ( -- ? ) deploy-io get 1 = ; @@ -27,7 +27,7 @@ SYMBOL: deploy-io SYMBOL: deploy-reflection -: deploy-reflection-options +CONSTANT: deploy-reflection-options { { 1 "Level 1 - No reflection" } { 2 "Level 2 - Retain word names" } @@ -35,7 +35,7 @@ SYMBOL: deploy-reflection { 4 "Level 4 - Debugger" } { 5 "Level 5 - Parser" } { 6 "Level 6 - Full environment" } - } ; + } : strip-word-names? ( -- ? ) deploy-reflection get 2 < ; : strip-prettyprint? ( -- ? ) deploy-reflection get 3 < ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 5095f9e93e..961d0ff26d 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -95,7 +95,7 @@ IN: tools.deploy.shaker "cannot-infer" "coercer" "combination" - "compiled-effect" + "compiled-status" "compiled-generic-uses" "compiled-uses" "constraints" @@ -190,7 +190,7 @@ IN: tools.deploy.shaker "Stripping default methods" show [ [ generic? ] instances - [ "No method" throw ] define-temp + [ "No method" throw ] (( -- * )) define-temp dup t "default" set-word-prop '[ [ _ "default-method" set-word-prop ] [ make-generic ] bi diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index 197ace74d8..5bf62ef156 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -1,6 +1,6 @@ IN: tools.profiler.tests USING: accessors tools.profiler tools.test kernel memory math -threads alien tools.profiler.private sequences compiler.units +threads alien tools.profiler.private sequences compiler words ; [ t ] [ diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 3201779cc5..9e32f2f4de 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -14,15 +14,15 @@ IN: ui.cocoa.views #! Cocoa -> Factor UI button mapping -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ; -: modifiers +CONSTANT: modifiers { { S+ HEX: 20000 } { C+ HEX: 40000 } { A+ HEX: 100000 } { M+ HEX: 80000 } - } ; + } -: key-codes +CONSTANT: key-codes H{ { 71 "CLEAR" } { 36 "RET" } @@ -47,7 +47,7 @@ IN: ui.cocoa.views { 126 "UP" } { 116 "PAGE_UP" } { 121 "PAGE_DOWN" } - } ; + } : key-code ( event -- string ? ) dup -> keyCode key-codes at diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index dabc12d3ae..3deb280c83 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -173,7 +173,7 @@ TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ; diff --git a/basis/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor index ae4c7d929a..a4d6b46129 100644 --- a/basis/ui/gadgets/frames/frames.factor +++ b/basis/ui/gadgets/frames/frames.factor @@ -13,16 +13,16 @@ M: glue pref-dim* drop { 0 0 } ; : ( -- grid ) 9 [ ] replicate 3 group ; -: @center 1 1 ; inline -: @left 0 1 ; inline -: @right 2 1 ; inline -: @top 1 0 ; inline -: @bottom 1 2 ; inline +: @center ( -- i j ) 1 1 ; inline +: @left ( -- i j ) 0 1 ; inline +: @right ( -- i j ) 2 1 ; inline +: @top ( -- i j ) 1 0 ; inline +: @bottom ( -- i j ) 1 2 ; inline -: @top-left 0 0 ; inline -: @top-right 2 0 ; inline -: @bottom-left 0 2 ; inline -: @bottom-right 2 2 ; inline +: @top-left ( -- i j ) 0 0 ; inline +: @top-right ( -- i j ) 2 0 ; inline +: @bottom-left ( -- i j ) 0 2 ; inline +: @bottom-right ( -- i j ) 2 2 ; inline TUPLE: frame < grid ; diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 1c2055156e..f22bd08ba2 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -18,7 +18,7 @@ TUPLE: slider < frame elevator thumb saved line ; : elevator-length ( slider -- n ) [ elevator>> dim>> ] [ orientation>> ] bi v. ; -: min-thumb-dim 15 ; +CONSTANT: min-thumb-dim 15 : slider-value ( gadget -- n ) model>> range-value >fixnum ; : slider-page ( gadget -- n ) model>> range-page-value ; diff --git a/basis/ui/gadgets/theme/theme.factor b/basis/ui/gadgets/theme/theme.factor index 6ca3868d87..7dabd994c2 100644 --- a/basis/ui/gadgets/theme/theme.factor +++ b/basis/ui/gadgets/theme/theme.factor @@ -56,6 +56,6 @@ IN: ui.gadgets.theme T{ gray f 0.5 1.0 } } ; -: sans-serif-font { "sans-serif" plain 12 } ; +CONSTANT: sans-serif-font { "sans-serif" plain 12 } -: monospace-font { "monospace" plain 12 } ; +CONSTANT: monospace-font { "monospace" plain 12 } diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 5cbac9798a..a913c78f7d 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -191,11 +191,11 @@ M: polygon draw-interior [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ] tri ; -: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ; -: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ; -: arrow-down { { 0 0 } { 6 0 } { 3 6 } } ; -: arrow-left { { 0 3 } { 6 0 } { 6 6 } } ; -: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ; +CONSTANT: arrow-up { { 3 0 } { 6 6 } { 0 6 } } +CONSTANT: arrow-right { { 0 0 } { 6 3 } { 0 6 } } +CONSTANT: arrow-down { { 0 0 } { 6 0 } { 3 6 } } +CONSTANT: arrow-left { { 0 3 } { 6 0 } { 6 6 } } +CONSTANT: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } : ( color points -- gadget ) dup max-dim diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index de8d28ad2e..bff4ddeaab 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -97,8 +97,8 @@ VALUE: properties [ nip zero? not ] assoc-filter >hashtable ; -: categories ( -- names ) - ! For non-existent characters, use Cn +! For non-existent characters, use Cn +CONSTANT: categories { "Cn" "Lu" "Ll" "Lt" "Lm" "Lo" "Mn" "Mc" "Me" @@ -106,9 +106,9 @@ VALUE: properties "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po" "Sm" "Sc" "Sk" "So" "Zs" "Zl" "Zp" - "Cc" "Cf" "Cs" "Co" } ; + "Cc" "Cf" "Cs" "Co" } -: num-chars HEX: 2FA1E ; +CONSTANT: num-chars HEX: 2FA1E ! the maximum unicode char in the first 3 planes diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 8a271f7210..36acc5e346 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -993,8 +993,8 @@ FUNCTION: BOOL DuplicateHandle ( BOOL bInheritHandle, DWORD dwOptions ) ; -: DUPLICATE_CLOSE_SOURCE 1 ; -: DUPLICATE_SAME_ACCESS 2 ; +CONSTANT: DUPLICATE_CLOSE_SOURCE 1 +CONSTANT: DUPLICATE_SAME_ACCESS 2 ! FUNCTION: EncodePointer ! FUNCTION: EncodeSystemPointer diff --git a/basis/x11/constants/constants.factor b/basis/x11/constants/constants.factor index fcce09380f..1fe825d6af 100644 --- a/basis/x11/constants/constants.factor +++ b/basis/x11/constants/constants.factor @@ -12,17 +12,17 @@ TYPEDEF: uchar KeyCode ! Reserved Resource and Constant Definitions -: ParentRelative 1 ; -: CopyFromParent 0 ; -: PointerWindow 0 ; -: InputFocus 1 ; -: PointerRoot 1 ; -: AnyPropertyType 0 ; -: AnyKey 0 ; -: AnyButton 0 ; -: AllTemporary 0 ; -: CurrentTime 0 ; -: NoSymbol 0 ; +CONSTANT: ParentRelative 1 +CONSTANT: CopyFromParent 0 +CONSTANT: PointerWindow 0 +CONSTANT: InputFocus 1 +CONSTANT: PointerRoot 1 +CONSTANT: AnyPropertyType 0 +CONSTANT: AnyKey 0 +CONSTANT: AnyButton 0 +CONSTANT: AllTemporary 0 +CONSTANT: CurrentTime 0 +CONSTANT: NoSymbol 0 ! Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer, ! state in various key-, mouse-, and button-related events. @@ -31,14 +31,14 @@ TYPEDEF: uchar KeyCode ! modifier names. Used to build a SetModifierMapping request or ! to read a GetModifierMapping request. These correspond to the ! masks defined above. -: ShiftMapIndex 0 ; -: LockMapIndex 1 ; -: ControlMapIndex 2 ; -: Mod1MapIndex 3 ; -: Mod2MapIndex 4 ; -: Mod3MapIndex 5 ; -: Mod4MapIndex 6 ; -: Mod5MapIndex 7 ; +CONSTANT: ShiftMapIndex 0 +CONSTANT: LockMapIndex 1 +CONSTANT: ControlMapIndex 2 +CONSTANT: Mod1MapIndex 3 +CONSTANT: Mod2MapIndex 4 +CONSTANT: Mod3MapIndex 5 +CONSTANT: Mod4MapIndex 6 +CONSTANT: Mod5MapIndex 7 ! button masks. Used in same manner as Key masks above. Not to be confused @@ -53,100 +53,100 @@ TYPEDEF: uchar KeyCode ! Notify modes -: NotifyNormal 0 ; -: NotifyGrab 1 ; -: NotifyUngrab 2 ; -: NotifyWhileGrabbed 3 ; +CONSTANT: NotifyNormal 0 +CONSTANT: NotifyGrab 1 +CONSTANT: NotifyUngrab 2 +CONSTANT: NotifyWhileGrabbed 3 -: NotifyHint 1 ; ! for MotionNotify events +CONSTANT: NotifyHint 1 ! for MotionNotify events ! Notify detail -: NotifyAncestor 0 ; -: NotifyVirtual 1 ; -: NotifyInferior 2 ; -: NotifyNonlinear 3 ; -: NotifyNonlinearVirtual 4 ; -: NotifyPointer 5 ; -: NotifyPointerRoot 6 ; -: NotifyDetailNone 7 ; +CONSTANT: NotifyAncestor 0 +CONSTANT: NotifyVirtual 1 +CONSTANT: NotifyInferior 2 +CONSTANT: NotifyNonlinear 3 +CONSTANT: NotifyNonlinearVirtual 4 +CONSTANT: NotifyPointer 5 +CONSTANT: NotifyPointerRoot 6 +CONSTANT: NotifyDetailNone 7 ! Visibility notify -: VisibilityUnobscured 0 ; -: VisibilityPartiallyObscured 1 ; -: VisibilityFullyObscured 2 ; +CONSTANT: VisibilityUnobscured 0 +CONSTANT: VisibilityPartiallyObscured 1 +CONSTANT: VisibilityFullyObscured 2 ! Circulation request -: PlaceOnTop 0 ; -: PlaceOnBottom 1 ; +CONSTANT: PlaceOnTop 0 +CONSTANT: PlaceOnBottom 1 ! protocol families -: FamilyInternet 0 ; ! IPv4 -: FamilyDECnet 1 ; -: FamilyChaos 2 ; -: FamilyInternet6 6 ; ! IPv6 +CONSTANT: FamilyInternet 0 ! IPv4 +CONSTANT: FamilyDECnet 1 +CONSTANT: FamilyChaos 2 +CONSTANT: FamilyInternet6 6 ! IPv6 ! authentication families not tied to a specific protocol -: FamilyServerInterpreted 5 ; +CONSTANT: FamilyServerInterpreted 5 ! Property notification -: PropertyNewValue 0 ; -: PropertyDelete 1 ; +CONSTANT: PropertyNewValue 0 +CONSTANT: PropertyDelete 1 ! Color Map notification -: ColormapUninstalled 0 ; -: ColormapInstalled 1 ; +CONSTANT: ColormapUninstalled 0 +CONSTANT: ColormapInstalled 1 ! GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes -: GrabModeSync 0 ; -: GrabModeAsync 1 ; +CONSTANT: GrabModeSync 0 +CONSTANT: GrabModeAsync 1 ! GrabPointer, GrabKeyboard reply status -: GrabSuccess 0 ; -: AlreadyGrabbed 1 ; -: GrabInvalidTime 2 ; -: GrabNotViewable 3 ; -: GrabFrozen 4 ; +CONSTANT: GrabSuccess 0 +CONSTANT: AlreadyGrabbed 1 +CONSTANT: GrabInvalidTime 2 +CONSTANT: GrabNotViewable 3 +CONSTANT: GrabFrozen 4 ! AllowEvents modes -: AsyncPointer 0 ; -: SyncPointer 1 ; -: ReplayPointer 2 ; -: AsyncKeyboard 3 ; -: SyncKeyboard 4 ; -: ReplayKeyboard 5 ; -: AsyncBoth 6 ; -: SyncBoth 7 ; +CONSTANT: AsyncPointer 0 +CONSTANT: SyncPointer 1 +CONSTANT: ReplayPointer 2 +CONSTANT: AsyncKeyboard 3 +CONSTANT: SyncKeyboard 4 +CONSTANT: ReplayKeyboard 5 +CONSTANT: AsyncBoth 6 +CONSTANT: SyncBoth 7 ! Used in SetInputFocus, GetInputFocus : RevertToNone ( -- n ) None ; : RevertToPointerRoot ( -- n ) PointerRoot ; -: RevertToParent 2 ; +CONSTANT: RevertToParent 2 ! ***************************************************************** ! * ERROR CODES ! ***************************************************************** -: Success 0 ; ! everything's okay -: BadRequest 1 ; ! bad request code -: BadValue 2 ; ! int parameter out of range -: BadWindow 3 ; ! parameter not a Window -: BadPixmap 4 ; ! parameter not a Pixmap -: BadAtom 5 ; ! parameter not an Atom -: BadCursor 6 ; ! parameter not a Cursor -: BadFont 7 ; ! parameter not a Font -: BadMatch 8 ; ! parameter mismatch -: BadDrawable 9 ; ! parameter not a Pixmap or Window -: BadAccess 10 ; ! depending on context: +CONSTANT: Success 0 ! everything's okay +CONSTANT: BadRequest 1 ! bad request code +CONSTANT: BadValue 2 ! int parameter out of range +CONSTANT: BadWindow 3 ! parameter not a Window +CONSTANT: BadPixmap 4 ! parameter not a Pixmap +CONSTANT: BadAtom 5 ! parameter not an Atom +CONSTANT: BadCursor 6 ! parameter not a Cursor +CONSTANT: BadFont 7 ! parameter not a Font +CONSTANT: BadMatch 8 ! parameter mismatch +CONSTANT: BadDrawable 9 ! parameter not a Pixmap or Window +CONSTANT: BadAccess 10 ! depending on context: ! - key/button already grabbed ! - attempt to free an illegal ! cmap entry @@ -154,16 +154,16 @@ TYPEDEF: uchar KeyCode ! color map entry. ! - attempt to modify the access control ! list from other than the local host. -: BadAlloc 11 ; ! insufficient resources -: BadColor 12 ; ! no such colormap -: BadGC 13 ; ! parameter not a GC -: BadIDChoice 14 ; ! choice not in range or already used -: BadName 15 ; ! font or color name doesn't exist -: BadLength 16 ; ! Request length incorrect -: BadImplementation 17 ; ! server is defective +CONSTANT: BadAlloc 11 ! insufficient resources +CONSTANT: BadColor 12 ! no such colormap +CONSTANT: BadGC 13 ! parameter not a GC +CONSTANT: BadIDChoice 14 ! choice not in range or already used +CONSTANT: BadName 15 ! font or color name doesn't exist +CONSTANT: BadLength 16 ! Request length incorrect +CONSTANT: BadImplementation 17 ! server is defective -: FirstExtensionError 128 ; -: LastExtensionError 255 ; +CONSTANT: FirstExtensionError 128 +CONSTANT: LastExtensionError 255 ! ***************************************************************** ! * WINDOW DEFINITIONS @@ -172,44 +172,44 @@ TYPEDEF: uchar KeyCode ! Window classes used by CreateWindow ! Note that CopyFromParent is already defined as 0 above -: InputOutput 1 ; -: InputOnly 2 ; +CONSTANT: InputOutput 1 +CONSTANT: InputOnly 2 ! Used in CreateWindow for backing-store hint -: NotUseful 0 ; -: WhenMapped 1 ; -: Always 2 ; +CONSTANT: NotUseful 0 +CONSTANT: WhenMapped 1 +CONSTANT: Always 2 ! Used in ChangeSaveSet -: SetModeInsert 0 ; -: SetModeDelete 1 ; +CONSTANT: SetModeInsert 0 +CONSTANT: SetModeDelete 1 ! Used in ChangeCloseDownMode -: DestroyAll 0 ; -: RetainPermanent 1 ; -: RetainTemporary 2 ; +CONSTANT: DestroyAll 0 +CONSTANT: RetainPermanent 1 +CONSTANT: RetainTemporary 2 ! Window stacking method (in configureWindow) -: Above 0 ; -: Below 1 ; -: TopIf 2 ; -: BottomIf 3 ; -: Opposite 4 ; +CONSTANT: Above 0 +CONSTANT: Below 1 +CONSTANT: TopIf 2 +CONSTANT: BottomIf 3 +CONSTANT: Opposite 4 ! Circulation direction -: RaiseLowest 0 ; -: LowerHighest 1 ; +CONSTANT: RaiseLowest 0 +CONSTANT: LowerHighest 1 ! Property modes -: PropModeReplace 0 ; -: PropModePrepend 1 ; -: PropModeAppend 2 ; +CONSTANT: PropModeReplace 0 +CONSTANT: PropModePrepend 1 +CONSTANT: PropModeAppend 2 ! ***************************************************************** ! * GRAPHICS DEFINITIONS @@ -217,62 +217,62 @@ TYPEDEF: uchar KeyCode ! LineStyle -: LineSolid 0 ; -: LineOnOffDash 1 ; -: LineDoubleDash 2 ; +CONSTANT: LineSolid 0 +CONSTANT: LineOnOffDash 1 +CONSTANT: LineDoubleDash 2 ! capStyle -: CapNotLast 0 ; -: CapButt 1 ; -: CapRound 2 ; -: CapProjecting 3 ; +CONSTANT: CapNotLast 0 +CONSTANT: CapButt 1 +CONSTANT: CapRound 2 +CONSTANT: CapProjecting 3 ! joinStyle -: JoinMiter 0 ; -: JoinRound 1 ; -: JoinBevel 2 ; +CONSTANT: JoinMiter 0 +CONSTANT: JoinRound 1 +CONSTANT: JoinBevel 2 ! fillStyle -: FillSolid 0 ; -: FillTiled 1 ; -: FillStippled 2 ; -: FillOpaqueStippled 3 ; +CONSTANT: FillSolid 0 +CONSTANT: FillTiled 1 +CONSTANT: FillStippled 2 +CONSTANT: FillOpaqueStippled 3 ! fillRule -: EvenOddRule 0 ; -: WindingRule 1 ; +CONSTANT: EvenOddRule 0 +CONSTANT: WindingRule 1 ! subwindow mode -: ClipByChildren 0 ; -: IncludeInferiors 1 ; +CONSTANT: ClipByChildren 0 +CONSTANT: IncludeInferiors 1 ! SetClipRectangles ordering -: Unsorted 0 ; -: YSorted 1 ; -: YXSorted 2 ; -: YXBanded 3 ; +CONSTANT: Unsorted 0 +CONSTANT: YSorted 1 +CONSTANT: YXSorted 2 +CONSTANT: YXBanded 3 ! CoordinateMode for drawing routines -: CoordModeOrigin 0 ; ! relative to the origin -: CoordModePrevious 1 ; ! relative to previous point +CONSTANT: CoordModeOrigin 0 ! relative to the origin +CONSTANT: CoordModePrevious 1 ! relative to previous point ! Polygon shapes -: Complex 0 ; ! paths may intersect -: Nonconvex 1 ; ! no paths intersect, but not convex -: Convex 2 ; ! wholly convex +CONSTANT: Complex 0 ! paths may intersect +CONSTANT: Nonconvex 1 ! no paths intersect, but not convex +CONSTANT: Convex 2 ! wholly convex ! Arc modes for PolyFillArc -: ArcChord 0 ; ! join endpoints of arc -: ArcPieSlice 1 ; ! join endpoints to center of arc +CONSTANT: ArcChord 0 ! join endpoints of arc +CONSTANT: ArcPieSlice 1 ! join endpoints to center of arc ! ***************************************************************** ! * FONTS @@ -280,10 +280,10 @@ TYPEDEF: uchar KeyCode ! used in QueryFont -- draw direction -: FontLeftToRight 0 ; -: FontRightToLeft 1 ; +CONSTANT: FontLeftToRight 0 +CONSTANT: FontRightToLeft 1 -: FontChange 255 ; +CONSTANT: FontChange 255 ! ***************************************************************** ! * IMAGING @@ -291,9 +291,9 @@ TYPEDEF: uchar KeyCode ! ImageFormat -- PutImage, GetImage -: XYBitmap 0 ; ! depth 1, XYFormat -: XYPixmap 1 ; ! depth == drawable depth -: ZPixmap 2 ; ! depth == drawable depth +CONSTANT: XYBitmap 0 ! depth 1, XYFormat +CONSTANT: XYPixmap 1 ! depth == drawable depth +CONSTANT: ZPixmap 2 ! depth == drawable depth ! ***************************************************************** ! * COLOR MAP STUFF @@ -301,8 +301,8 @@ TYPEDEF: uchar KeyCode ! For CreateColormap -: AllocNone 0 ; ! create map with no entries -: AllocAll 1 ; ! allocate entire map writeable +CONSTANT: AllocNone 0 ! create map with no entries +CONSTANT: AllocAll 1 ! allocate entire map writeable ! Flags used in StoreNamedColor, StoreColors @@ -317,20 +317,20 @@ TYPEDEF: uchar KeyCode ! QueryBestSize Class -: CursorShape 0 ; ! largest size that can be displayed -: TileShape 1 ; ! size tiled fastest -: StippleShape 2 ; ! size stippled fastest +CONSTANT: CursorShape 0 ! largest size that can be displayed +CONSTANT: TileShape 1 ! size tiled fastest +CONSTANT: StippleShape 2 ! size stippled fastest ! ***************************************************************** ! * KEYBOARD/POINTER STUFF ! ***************************************************************** -: AutoRepeatModeOff 0 ; -: AutoRepeatModeOn 1 ; -: AutoRepeatModeDefault 2 ; +CONSTANT: AutoRepeatModeOff 0 +CONSTANT: AutoRepeatModeOn 1 +CONSTANT: AutoRepeatModeDefault 2 -: LedModeOff 0 ; -: LedModeOn 1 ; +CONSTANT: LedModeOff 0 +CONSTANT: LedModeOn 1 ! masks for ChangeKeyboardControl @@ -343,33 +343,33 @@ TYPEDEF: uchar KeyCode : KBKey ( -- n ) 6 2^ ; : KBAutoRepeatMode ( -- n ) 7 2^ ; -: MappingSuccess 0 ; -: MappingBusy 1 ; -: MappingFailed 2 ; +CONSTANT: MappingSuccess 0 +CONSTANT: MappingBusy 1 +CONSTANT: MappingFailed 2 -: MappingModifier 0 ; -: MappingKeyboard 1 ; -: MappingPointer 2 ; +CONSTANT: MappingModifier 0 +CONSTANT: MappingKeyboard 1 +CONSTANT: MappingPointer 2 ! ***************************************************************** ! * SCREEN SAVER STUFF ! ***************************************************************** -: DontPreferBlanking 0 ; -: PreferBlanking 1 ; -: DefaultBlanking 2 ; +CONSTANT: DontPreferBlanking 0 +CONSTANT: PreferBlanking 1 +CONSTANT: DefaultBlanking 2 -: DisableScreenSaver 0 ; -: DisableScreenInterval 0 ; +CONSTANT: DisableScreenSaver 0 +CONSTANT: DisableScreenInterval 0 -: DontAllowExposures 0 ; -: AllowExposures 1 ; -: DefaultExposures 2 ; +CONSTANT: DontAllowExposures 0 +CONSTANT: AllowExposures 1 +CONSTANT: DefaultExposures 2 ! for ForceScreenSaver -: ScreenSaverReset 0 ; -: ScreenSaverActive 1 ; +CONSTANT: ScreenSaverReset 0 +CONSTANT: ScreenSaverActive 1 ! ***************************************************************** ! * HOSTS AND CONNECTIONS @@ -377,30 +377,30 @@ TYPEDEF: uchar KeyCode ! for ChangeHosts -: HostInsert 0 ; -: HostDelete 1 ; +CONSTANT: HostInsert 0 +CONSTANT: HostDelete 1 ! for ChangeAccessControl -: EnableAccess 1 ; -: DisableAccess 0 ; +CONSTANT: EnableAccess 1 +CONSTANT: DisableAccess 0 ! Display classes used in opening the connection ! Note that the statically allocated ones are even numbered and the ! dynamically changeable ones are odd numbered -: StaticGray 0 ; -: GrayScale 1 ; -: StaticColor 2 ; -: PseudoColor 3 ; -: TrueColor 4 ; -: DirectColor 5 ; +CONSTANT: StaticGray 0 +CONSTANT: GrayScale 1 +CONSTANT: StaticColor 2 +CONSTANT: PseudoColor 3 +CONSTANT: TrueColor 4 +CONSTANT: DirectColor 5 ! Byte order used in imageByteOrder and bitmapBitOrder -: LSBFirst 0 ; -: MSBFirst 1 ; +CONSTANT: LSBFirst 0 +CONSTANT: MSBFirst 1 ! ***************************************************************** ! * EXTENDED WINDOW MANAGER HINTS diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index 11473d6e83..e6001d3e59 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -9,23 +9,23 @@ IN: x11.glx LIBRARY: glx ! Visual Config Attributes (glXGetConfig, glXGetFBConfigAttrib) -: GLX_USE_GL 1 ; ! support GLX rendering -: GLX_BUFFER_SIZE 2 ; ! depth of the color buffer -: GLX_LEVEL 3 ; ! level in plane stacking -: GLX_RGBA 4 ; ! true if RGBA mode -: GLX_DOUBLEBUFFER 5 ; ! double buffering supported -: GLX_STEREO 6 ; ! stereo buffering supported -: GLX_AUX_BUFFERS 7 ; ! number of aux buffers -: GLX_RED_SIZE 8 ; ! number of red component bits -: GLX_GREEN_SIZE 9 ; ! number of green component bits -: GLX_BLUE_SIZE 10 ; ! number of blue component bits -: GLX_ALPHA_SIZE 11 ; ! number of alpha component bits -: GLX_DEPTH_SIZE 12 ; ! number of depth bits -: GLX_STENCIL_SIZE 13 ; ! number of stencil bits -: GLX_ACCUM_RED_SIZE 14 ; ! number of red accum bits -: GLX_ACCUM_GREEN_SIZE 15 ; ! number of green accum bits -: GLX_ACCUM_BLUE_SIZE 16 ; ! number of blue accum bits -: GLX_ACCUM_ALPHA_SIZE 17 ; ! number of alpha accum bits +CONSTANT: GLX_USE_GL 1 ! support GLX rendering +CONSTANT: GLX_BUFFER_SIZE 2 ! depth of the color buffer +CONSTANT: GLX_LEVEL 3 ! level in plane stacking +CONSTANT: GLX_RGBA 4 ! true if RGBA mode +CONSTANT: GLX_DOUBLEBUFFER 5 ! double buffering supported +CONSTANT: GLX_STEREO 6 ! stereo buffering supported +CONSTANT: GLX_AUX_BUFFERS 7 ! number of aux buffers +CONSTANT: GLX_RED_SIZE 8 ! number of red component bits +CONSTANT: GLX_GREEN_SIZE 9 ! number of green component bits +CONSTANT: GLX_BLUE_SIZE 10 ! number of blue component bits +CONSTANT: GLX_ALPHA_SIZE 11 ! number of alpha component bits +CONSTANT: GLX_DEPTH_SIZE 12 ! number of depth bits +CONSTANT: GLX_STENCIL_SIZE 13 ! number of stencil bits +CONSTANT: GLX_ACCUM_RED_SIZE 14 ! number of red accum bits +CONSTANT: GLX_ACCUM_GREEN_SIZE 15 ! number of green accum bits +CONSTANT: GLX_ACCUM_BLUE_SIZE 16 ! number of blue accum bits +CONSTANT: GLX_ACCUM_ALPHA_SIZE 17 ! number of alpha accum bits TYPEDEF: XID GLXContextID TYPEDEF: XID GLXPixmap diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 534e47ac37..e06872fa83 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -34,7 +34,7 @@ SYMBOL: xim XNResourceClass over 0 XCreateIC [ "XCreateIC() failed" throw ] unless* ; -: buf-size 100 ; +CONSTANT: buf-size 100 SYMBOL: keybuf SYMBOL: keysym diff --git a/basis/xml/entities/entities.factor b/basis/xml/entities/entities.factor index 3e768b1b88..7eac725052 100644 --- a/basis/xml/entities/entities.factor +++ b/basis/xml/entities/entities.factor @@ -4,20 +4,20 @@ USING: namespaces make kernel assocs sequences fry values io.files io.encodings.binary xml.state ; IN: xml.entities -: entities-out +CONSTANT: entities-out H{ { CHAR: < "<" } { CHAR: > ">" } { CHAR: & "&" } - } ; + } -: quoted-entities-out +CONSTANT: quoted-entities-out H{ { CHAR: & "&" } { CHAR: ' "'" } { CHAR: " """ } { CHAR: < "<" } - } ; + } : escape-string-by ( str table -- escaped ) #! Convert <, >, &, ' and " to HTML entities. @@ -29,14 +29,14 @@ IN: xml.entities : escape-quoted-string ( str -- newstr ) quoted-entities-out escape-string-by ; -: entities +CONSTANT: entities H{ { "lt" CHAR: < } { "gt" CHAR: > } { "amp" CHAR: & } { "apos" CHAR: ' } { "quot" CHAR: " } - } ; + } : with-entities ( entities quot -- ) [ swap extra-entities set call ] with-scope ; inline diff --git a/basis/xml/errors/errors.factor b/basis/xml/errors/errors.factor index 304b38f2bd..35111f5a54 100644 --- a/basis/xml/errors/errors.factor +++ b/basis/xml/errors/errors.factor @@ -290,7 +290,7 @@ M: quoteless-attr summary TUPLE: attr-w/< < xml-error-at ; -: attr-w/< ( value -- * ) +: attr-w/< ( -- * ) \ attr-w/< xml-error-at throw ; M: attr-w/< summary @@ -299,7 +299,7 @@ M: attr-w/< summary TUPLE: text-w/]]> < xml-error-at ; -: text-w/]]> ( text -- * ) +: text-w/]]> ( -- * ) \ text-w/]]> xml-error-at throw ; M: text-w/]]> summary diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index ceeab571b8..9e064cf99c 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -538,4 +538,4 @@ tuple [ [ first2 ] dip make-primitive ] each-index ! Bump build number -"build" "kernel" create build 1+ 1quotation define +"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index 09baf91018..46d3dbc33f 100644 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -67,7 +67,3 @@ HELP: modify-code-heap ( alist -- ) HELP: compile { $values { "words" "a sequence of words" } } { $description "Compiles a set of words." } ; - -HELP: compile-call -{ $values { "quot" "a quotation" } } -{ $description "Compiles and runs a quotation." } ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index ac3e99e24c..0577f8b83c 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -172,9 +172,6 @@ SYMBOL: remake-generics-hook ] [ ] cleanup ] with-scope ; inline -: compile-call ( quot -- ) - [ define-temp ] with-compilation-unit execute ; - : default-recompile-hook ( words -- alist ) [ f ] { } map>assoc ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index c7056856b6..37418b85f5 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -92,10 +92,10 @@ C: continuation PRIVATE> -: continue-with ( obj continuation -- ) +: continue-with ( obj continuation -- * ) [ (continue-with) ] 2 (throw) ; -: continue ( continuation -- ) +: continue ( continuation -- * ) f swap continue-with ; SYMBOL: return-continuation @@ -103,7 +103,7 @@ SYMBOL: return-continuation : with-return ( quot -- ) [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline -: return ( -- ) +: return ( -- * ) return-continuation get continue ; : with-datastack ( stack quot -- newstack ) @@ -173,7 +173,7 @@ TUPLE: restart name obj continuation ; C: restart -: restart ( restart -- ) +: restart ( restart -- * ) [ obj>> ] [ continuation>> ] bi continue-with ; M: object compute-restarts drop { } ; diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 8a06653eb8..a9f9634d46 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -44,9 +44,9 @@ M: effect effect>string ( effect -- string ) GENERIC: stack-effect ( word -- effect/f ) -M: word stack-effect - { "declared-effect" "inferred-effect" } - swap props>> [ at ] curry map [ ] find nip ; +M: word stack-effect "declared-effect" word-prop ; + +M: deferred stack-effect call-next-method (( -- * )) or ; M: effect clone [ in>> clone ] [ out>> clone ] bi ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 9ace1a01f4..f9fe3a6e9e 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -50,16 +50,16 @@ ERROR: no-method object generic ; convert-hi-tag-methods ; +: mangle-method ( method -- quot ) + 1quotation generic get extra-values \ drop + prepend [ ] like ; + : find-default ( methods -- quot ) #! Side-effects methods. object bootstrap-word swap delete-at* [ - drop generic get "default-method" word-prop 1quotation + drop generic get "default-method" word-prop mangle-method ] unless ; -: mangle-method ( method generic -- quot ) - [ 1quotation ] [ extra-values \ drop ] bi* - prepend [ ] like ; - : ( word -- engine ) object bootstrap-word assumed set { [ generic set ] @@ -67,7 +67,7 @@ ERROR: no-method object generic ; [ V{ } clone "engines" set-word-prop ] [ "methods" word-prop - [ generic get mangle-method ] assoc-map + [ mangle-method ] assoc-map [ find-default default set ] [ ] bi diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 4dfa2d49bc..f5990c295e 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -288,12 +288,12 @@ HELP: define-declared { $side-effects "word" } ; HELP: define-temp -{ $values { "quot" quotation } { "word" word } } +{ $values { "quot" quotation } { "effect" effect } { "word" word } } { $description "Creates an uninterned word that will call " { $snippet "quot" } " when executed." } { $notes "The following phrases are equivalent:" { $code "[ 2 2 + . ] call" } - { $code "[ 2 2 + . ] define-temp execute" } + { $code "[ 2 2 + . ] (( -- )) define-temp execute" } "This word must be called from inside " { $link with-compilation-unit } "." } ; diff --git a/core/words/words.factor b/core/words/words.factor index 4a3c1b2d52..43a391e46a 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -212,8 +212,8 @@ M: word subwords drop f ; : gensym ( -- word ) "( gensym )" f ; -: define-temp ( quot -- word ) - [ gensym dup ] dip define ; +: define-temp ( quot effect -- word ) + [ gensym dup ] 2dip define-declared ; : reveal ( word -- ) dup [ name>> ] [ vocabulary>> ] bi dup vocab-words diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index f842d5f4cb..f22ca001f4 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -7,7 +7,7 @@ arrays words quotations accessors math.parser backtrack assocs ; IN: 24-game SYMBOL: commands -: nop ; +: nop ( -- ) ; : do-something ( a b -- c ) { + - * } amb-execute ; : maybe-swap ( a b -- a b ) { nop swap } amb-execute ; : some-rots ( a b c -- a b c ) diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor index df67872b11..0ae7d792dd 100755 --- a/extra/benchmark/backtrack/backtrack.factor +++ b/extra/benchmark/backtrack/backtrack.factor @@ -10,7 +10,7 @@ IN: benchmark.backtrack ! placing them on the stack, and applying the operations ! +, -, * and rot as many times as we wish. -: nop ; +: nop ( -- ) ; : do-something ( a b -- c ) { + - * } amb-execute ; @@ -42,7 +42,7 @@ MEMO: 24-from-4 ( a b c d -- ? ) ] sigma ] sigma ; -: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ; +CONSTANT: words { 24-from-1 24-from-2 24-from-3 24-from-4 } : backtrack-benchmark ( -- ) words [ reset-memoized ] each diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 61d9e9fd43..2ae5ada8a1 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -10,8 +10,6 @@ CONSTANT: IC 29573 CONSTANT: initial-seed 42 CONSTANT: line-length 60 -USE: math.private - : random ( seed -- n seed ) >float IA * IC + IM mod [ IM /f ] keep ; inline @@ -19,7 +17,7 @@ HINTS: random fixnum ; CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA" -: IUB +CONSTANT: IUB { { CHAR: a 0.27 } { CHAR: c 0.12 } @@ -37,15 +35,15 @@ CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC { CHAR: V 0.02 } { CHAR: W 0.02 } { CHAR: Y 0.02 } - } ; inline + } -: homo-sapiens +CONSTANT: homo-sapiens { { CHAR: a 0.3029549426680 } { CHAR: c 0.1979883004921 } { CHAR: g 0.1975473066391 } { CHAR: t 0.3015094502008 } - } ; inline + } : make-cumulative ( freq -- chars floats ) dup keys >byte-array diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 8d07ae1c65..a4df1fe04d 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -8,13 +8,14 @@ hints ; IN: benchmark.raytracer ! parameters -: light - #! Normalized { -1 -3 2 }. + +! Normalized { -1 -3 2 }. +CONSTANT: light double-array{ -0.2672612419124244 -0.8017837257372732 0.5345224838248488 - } ; inline + } CONSTANT: oversampling 4 diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 20c905156b..d6e4f29b86 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -10,7 +10,7 @@ SYMBOL: counter SYMBOL: port-promise SYMBOL: server -: number-of-requests 1000 ; +CONSTANT: number-of-requests 1000 : server-addr ( -- addr ) "127.0.0.1" port-promise get ?promise ; diff --git a/extra/galois-talk/galois-talk.factor b/extra/galois-talk/galois-talk.factor index 259fa446af..ccba90fb6f 100644 --- a/extra/galois-talk/galois-talk.factor +++ b/extra/galois-talk/galois-talk.factor @@ -8,7 +8,7 @@ help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: galois-talk -: galois-slides +CONSTANT: galois-slides { { $slide "Factor!" { $url "http://factorcode.org" } @@ -305,7 +305,7 @@ IN: galois-talk "Factor has many cool things that I didn't talk about" "Questions?" } -} ; +} : galois-talk ( -- ) galois-slides slides-window ; diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index 8a10535306..254ed61ab0 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -121,12 +121,12 @@ CONSTANT: hat-switch-matching-hash : hat-switch? ( {usage-page,usage} -- ? ) { 1 HEX: 39 } = ; inline -: pov-values +CONSTANT: pov-values { pov-up pov-up-right pov-right pov-down-right pov-down pov-down-left pov-left pov-up-left pov-neutral - } ; inline + } : button-value ( value -- f/(0,1] ) IOHIDValueGetIntegerValue dup zero? [ drop f ] when ; diff --git a/extra/google-tech-talk/google-tech-talk.factor b/extra/google-tech-talk/google-tech-talk.factor index 9bd3c5854b..4d4e3b0507 100644 --- a/extra/google-tech-talk/google-tech-talk.factor +++ b/extra/google-tech-talk/google-tech-talk.factor @@ -8,7 +8,7 @@ help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: google-tech-talk -: google-slides +CONSTANT: google-slides { { $slide "Factor!" { $url "http://factorcode.org" } @@ -562,7 +562,7 @@ IN: google-tech-talk "Put your prejudices aside and give it a shot!" } { $slide "Questions?" } -} ; +} : google-talk ( -- ) google-slides slides-window ; diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 0eba6f6af5..2770471093 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -12,7 +12,7 @@ IN: irc.client ! Setup and running objects ! ====================================== -: irc-port 6667 ; ! Default irc port +CONSTANT: irc-port 6667 ! Default irc port TUPLE: irc-profile server port nickname password ; C: irc-profile diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 59e4cf6cb4..791639d260 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -28,9 +28,9 @@ TUPLE: irc-tab < frame chat client window ; : write-color ( str color -- ) foreground associate format ; -: dark-red T{ rgba f 0.5 0.0 0.0 1 } ; -: dark-green T{ rgba f 0.0 0.5 0.0 1 } ; -: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ; +CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 } +CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 } +CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 } : dot-or-parens ( string -- string ) [ "." ] diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index 9e457c7bdd..188095dd2e 100755 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -5,8 +5,8 @@ calendar locals strings ui.gadgets.buttons combinators math.parser assocs threads ; IN: joystick-demo -: SIZE { 151 151 } ; -: INDICATOR-SIZE { 4 4 } ; +CONSTANT: SIZE { 151 151 } +CONSTANT: INDICATOR-SIZE { 4 4 } : FREQUENCY ( -- f ) 30 recip seconds ; TUPLE: axis-gadget < gadget indicator z-indicator pov ; @@ -21,7 +21,7 @@ M: axis-gadget pref-dim* drop SIZE ; : indicator-polygon ( -- polygon ) { 0 0 } INDICATOR-SIZE (rect-polygon) ; -: pov-polygons +CONSTANT: pov-polygons V{ { pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } } { pov-up { { 70 65 } { 75 60 } { 80 65 } } } @@ -32,7 +32,7 @@ M: axis-gadget pref-dim* drop SIZE ; { pov-down-left { { 67 90 } { 60 90 } { 60 83 } } } { pov-left { { 65 70 } { 60 75 } { 65 80 } } } { pov-up-left { { 67 60 } { 60 60 } { 60 67 } } } - } ; + } : ( color -- indicator ) indicator-polygon ; diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor index 05edb205d2..acf20f90ab 100755 --- a/extra/key-caps/key-caps.factor +++ b/extra/key-caps/key-caps.factor @@ -4,7 +4,7 @@ words arrays assocs math calendar fry alarms ui ui.gadgets.borders ui.gestures ; IN: key-caps -: key-locations H{ +CONSTANT: key-locations H{ { key-escape { { 0 0 } { 10 10 } } } { key-f1 { { 20 0 } { 10 10 } } } @@ -129,9 +129,9 @@ IN: key-caps { key-keypad-0 { { 190 55 } { 20 10 } } } { key-keypad-. { { 210 55 } { 10 10 } } } -} ; +} -: KEYBOARD-SIZE { 230 65 } ; +CONSTANT: KEYBOARD-SIZE { 230 65 } : FREQUENCY ( -- f ) 30 recip seconds ; TUPLE: key-caps-gadget < gadget keys alarm ; diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index 849cc540a3..9877c70062 100755 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -42,7 +42,7 @@ SYMBOL: def-hash-keys set-alien-float alien-float } ; -: trivial-defs +: trivial-defs ( -- seq ) { [ drop ] [ 2array ] [ bitand ] diff --git a/extra/lisppaste/lisppaste.factor b/extra/lisppaste/lisppaste.factor index df85f01f26..43b5b78097 100644 --- a/extra/lisppaste/lisppaste.factor +++ b/extra/lisppaste/lisppaste.factor @@ -1,7 +1,7 @@ USING: arrays kernel xml-rpc ; IN: lisppaste -: url "http://www.common-lisp.net:8185/RPC2" ; +CONSTANT: url "http://www.common-lisp.net:8185/RPC2" : channels ( -- seq ) { } "listchannels" url invoke-method ; diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index ec0cbdbc9c..3cd38e1ff4 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -67,24 +67,24 @@ SYMBOL: stamp : ?prepare-build-machine ( -- ) builds/factor exists? [ prepare-build-machine ] unless ; -: load-everything-vocabs-file "load-everything-vocabs" ; -: load-everything-errors-file "load-everything-errors" ; +CONSTANT: load-everything-vocabs-file "load-everything-vocabs" +CONSTANT: load-everything-errors-file "load-everything-errors" -: test-all-vocabs-file "test-all-vocabs" ; -: test-all-errors-file "test-all-errors" ; +CONSTANT: test-all-vocabs-file "test-all-vocabs" +CONSTANT: test-all-errors-file "test-all-errors" -: help-lint-vocabs-file "help-lint-vocabs" ; -: help-lint-errors-file "help-lint-errors" ; +CONSTANT: help-lint-vocabs-file "help-lint-vocabs" +CONSTANT: help-lint-errors-file "help-lint-errors" -: boot-time-file "boot-time" ; -: load-time-file "load-time" ; -: compiler-errors-file "compiler-errors" ; -: test-time-file "test-time" ; -: help-lint-time-file "help-lint-time" ; -: benchmark-time-file "benchmark-time" ; -: html-help-time-file "html-help-time" ; +CONSTANT: boot-time-file "boot-time" +CONSTANT: load-time-file "load-time" +CONSTANT: compiler-errors-file "compiler-errors" +CONSTANT: test-time-file "test-time" +CONSTANT: help-lint-time-file "help-lint-time" +CONSTANT: benchmark-time-file "benchmark-time" +CONSTANT: html-help-time-file "html-help-time" -: benchmarks-file "benchmarks" ; +CONSTANT: benchmarks-file "benchmarks" SYMBOL: status diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor index 9c773f748e..fa01b0376d 100755 --- a/extra/math/analysis/analysis.factor +++ b/extra/math/analysis/analysis.factor @@ -11,11 +11,11 @@ IN: math.analysis CONSTANT: gamma-g6 5.15 -: gamma-p6 +CONSTANT: gamma-p6 { 2.50662827563479526904 225.525584619175212544 -268.295973841304927459 80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556 - } ; inline + } : gamma-z ( x n -- seq ) [ + recip ] with map 1.0 0 pick set-nth ; diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index de345e732e..a490a8bbfc 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -4,7 +4,7 @@ arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render math.order math.geometry.rect ; IN: maze -: line-width 8 ; +CONSTANT: line-width 8 SYMBOL: visited diff --git a/extra/minneapolis-talk/minneapolis-talk.factor b/extra/minneapolis-talk/minneapolis-talk.factor index 25bad4061a..6f1df44bfb 100755 --- a/extra/minneapolis-talk/minneapolis-talk.factor +++ b/extra/minneapolis-talk/minneapolis-talk.factor @@ -2,7 +2,7 @@ USING: slides help.markup math arrays hashtables namespaces sequences kernel sequences parser memoize ; IN: minneapolis-talk -: minneapolis-slides +CONSTANT: minneapolis-slides { { $slide "What is Factor?" "Dynamically typed, stack language" @@ -175,7 +175,7 @@ IN: minneapolis-talk "Mailing list: factor-talk@lists.sf.net" } { $slide "Questions?" } -} ; +} : minneapolis-talk ( -- ) minneapolis-slides slides-window ; diff --git a/extra/minneapolis-talk/minneapolis-talk.txt b/extra/minneapolis-talk/minneapolis-talk.txt deleted file mode 100755 index 5310accf5b..0000000000 --- a/extra/minneapolis-talk/minneapolis-talk.txt +++ /dev/null @@ -1,116 +0,0 @@ -- how to create a small module -- editor integration -- presentations -- module system -- copy and paste factoring, inverse -- help system -- tetris -- memoization -- editing inspector demo -- dynamic scope, lexical scope - -Factor: contradictions? ------------------------ - -Have our cake and eat it too - -Research -vs- practical -High level -vs- fast -Interactive -vs- deployment - -Factor from 10,000 feet ------------------------ - -word: named function -vocabulary: module -quotation: anonymous function -classes, objects, etc. - -The stack ---------- - -- Stack -vs- applicative -- Pass by reference, dynamically typed -- Stack languages: you can omit names where they're not needed -- More compositional style -- If you need to name things for clarity, you can: - lexical vars, dynamic vars, sequences, assocs, objects... - -Functional programming ----------------------- - -Quotations -Curry -Continuations - -Object-oriented programming ---------------------------- - -Generic words: sort of like open classes -Tuple reshaping -Editing inspector - -Meta programming ----------------- - -Simple, orthogonal core - -Why use a stack at all? ------------------------ - -Nice idioms: 10 days ago -Copy and paste factoring -Easy meta-programming -Sequence operations correspond to functional operations: -- curry is adding at the front -- compose is append - -UI --- - -Written in Factor -renders with OpenGL -Windows, X11, Cocoa backends -You can call Windows, X11, Cocoa APIs directly -OpenGL 2.1 shaders, OpenAL 3D audio... - -Tools ------ - -Edit -Usages -Profiler -Easy to make your own tools - -Implementation --------------- - -Two compilers -Generational garbage collector -Non-blocking I/O - -Hands on --------- - -Community ---------- - -Factor started in 2003 -About a dozen contributors -Handful of "core contributors" -Web site: http://factorcode.org -IRC: #concatenative on irc.freenode.net -Mailing list: factor-talk@lists.sf.net - -C library interface -------------------- - -Efficient -No need to write C code -Supports floats, structs, unions, ... -Function pointers, callbacks -Here is an example - -TerminateProcess - -process-handle TerminateProcess diff --git a/extra/nehe/2/2.factor b/extra/nehe/2/2.factor index 29d4ccffc1..fdb53ef254 100644 --- a/extra/nehe/2/2.factor +++ b/extra/nehe/2/2.factor @@ -4,8 +4,8 @@ IN: nehe.2 TUPLE: nehe2-gadget < gadget ; -: width 256 ; -: height 256 ; +CONSTANT: width 256 +CONSTANT: height 256 : ( -- gadget ) nehe2-gadget new-gadget ; diff --git a/extra/nehe/3/3.factor b/extra/nehe/3/3.factor index 75f2e573cc..557655a029 100644 --- a/extra/nehe/3/3.factor +++ b/extra/nehe/3/3.factor @@ -4,8 +4,8 @@ IN: nehe.3 TUPLE: nehe3-gadget < gadget ; -: width 256 ; -: height 256 ; +CONSTANT: width 256 +CONSTANT: height 256 : ( -- gadget ) nehe3-gadget new-gadget ; diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor index fda22d2f1e..00308277ea 100644 --- a/extra/nehe/4/4.factor +++ b/extra/nehe/4/4.factor @@ -5,8 +5,8 @@ IN: nehe.4 TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; -: width 256 ; -: height 256 ; +CONSTANT: width 256 +CONSTANT: height 256 : redraw-interval ( -- dt ) 10 milliseconds ; : ( -- gadget ) diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor index 30d0991fd8..3723014c83 100755 --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -4,8 +4,8 @@ calendar ; IN: nehe.5 TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; -: width 256 ; -: height 256 ; +CONSTANT: width 256 +CONSTANT: height 256 : redraw-interval ( -- dt ) 10 milliseconds ; : ( -- gadget ) diff --git a/extra/otug-talk/otug-talk.factor b/extra/otug-talk/otug-talk.factor index b52749dbe1..ef5782dda7 100644 --- a/extra/otug-talk/otug-talk.factor +++ b/extra/otug-talk/otug-talk.factor @@ -39,7 +39,7 @@ M: png-gadget ungraft* ( gadget -- ) : $tetris ( element -- ) drop [ gadget. ] ($block) ; -: otug-slides +CONSTANT: otug-slides { { $slide "Factor!" { $url "http://factorcode.org" } @@ -361,7 +361,7 @@ var price = (order == null ? null : order.price);"> } "Factor has many cool things that I didn't talk about" "Questions?" } -} ; +} : otug-talk ( -- ) otug-slides slides-window ; diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index 0ce946dc49..ba21ba9c84 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -6,7 +6,7 @@ ui.gadgets.books ui.gadgets.panes ui.gestures ui.render parser accessors colors ; IN: slides -: stylesheet +CONSTANT: stylesheet H{ { default-span-style H{ @@ -40,7 +40,7 @@ IN: slides H{ { table-gap { 10 20 } } } } { bullet "\u0000b7" } - } ; + } : $title ( string -- ) [ H{ { font "sans-serif" } { font-size 48 } } format ] ($block) ; diff --git a/extra/vpri-talk/vpri-talk.factor b/extra/vpri-talk/vpri-talk.factor index 35d8bb52ff..5d7620101f 100644 --- a/extra/vpri-talk/vpri-talk.factor +++ b/extra/vpri-talk/vpri-talk.factor @@ -8,7 +8,7 @@ help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry ; IN: vpri-talk -: vpri-slides +CONSTANT: vpri-slides { { $slide "Factor!" { $url "http://factorcode.org" } @@ -485,7 +485,7 @@ IN: vpri-talk "Factor has many cool things that I didn't talk about" "Questions?" } -} ; +} : vpri-talk ( -- ) vpri-slides slides-window ; diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index b58a11747f..5e0c08b430 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -18,8 +18,7 @@ format similar-ok language country site subscription license ; first3 ] map ; -: yahoo-url ( -- str ) - URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" ; +CONSTANT: yahoo-url URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" :: param ( search url name quot -- search url ) search url search quot call @@ -49,8 +48,7 @@ format similar-ok language country site subscription license ; "similar_ok" [ similar-ok>> ] bool-param nip ; -: factor-id - "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" ; +CONSTANT: factor-id "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" : ( query -- search ) search new diff --git a/unfinished/benchmark/richards/richards.factor b/unfinished/benchmark/richards/richards.factor deleted file mode 100644 index 90d4304eee..0000000000 --- a/unfinished/benchmark/richards/richards.factor +++ /dev/null @@ -1,272 +0,0 @@ -! Based on http://research.sun.com/people/mario/java_benchmarking/ -! Ported by Factor by Slava Pestov -! -! Based on original version written in BCPL by Dr Martin Richards -! in 1981 at Cambridge University Computer Laboratory, England -! Java version: Copyright (C) 1995 Sun Microsystems, Inc. -! by Jonathan Gibbons. -! Outer loop added 8/7/96 by Alex Jacoby -USING: values kernel accessors math math.bitwise sequences -arrays combinators fry locals ; -IN: benchmark.richards - -! Packets -TUPLE: packet link id kind a1 a2 ; - -: BUFSIZE 4 ; inline - -: ( link id kind -- packet ) - packet new - swap >>kind - swap >>id - swap >>link - 0 >>a1 - BUFSIZE 0 >>a2 ; - -: last-packet ( packet -- last ) - dup link>> [ last-packet ] [ ] ?if ; - -: append-to ( packet list -- packet ) - [ f >>link ] dip - [ tuck last-packet >>link drop ] when* ; - -! Tasks -: I_IDLE 1 ; inline -: I_WORK 2 ; inline -: I_HANDLERA 3 ; inline -: I_HANDLERB 4 ; inline -: I_DEVA 5 ; inline -: I_DEVB 6 ; inline - -! Packet types -: K_DEV 1000 ; inline -: K_WORK 1001 ; inline - -: PKTBIT 1 ; inline -: WAITBIT 2 ; inline -: HOLDBIT 4 ; inline - -: S_RUN 0 ; inline -: S_RUNPKT ( -- n ) { PKTBIT } flags ; inline -: S_WAIT ( -- n ) { WAITBIT } flags ; inline -: S_WAITPKT ( -- n ) { WAITBIT PKTBIT } flags ; inline -: S_HOLD ( -- n ) { HOLDBIT } flags ; inline -: S_HOLDPKT ( -- n ) { HOLDBIT PKTBIT } flags ; inline -: S_HOLDWAIT ( -- n ) { HOLDBIT WAITBIT } flags ; inline -: S_HOLDWAITPKT ( -- n ) { HOLDBIT WAITBIT PKTBIT } flags ; inline - -: task-tab-size 10 ; inline - -VALUE: task-tab -VALUE: task-list -VALUE: tracing -VALUE: hold-count -VALUE: qpkt-count - -TUPLE: task link id pri wkq state ; - -: new-task ( id pri wkq state class -- task ) - new - swap >>state - swap >>wkq - swap >>pri - swap >>id - task-list >>link - dup to: task-list - dup dup id>> task-tab set-nth ; inline - -GENERIC: fn ( packet task -- task ) - -: state-on ( task flag -- task ) - '[ _ bitor ] change-state ; inline - -: state-off ( task flag -- task ) - '[ _ bitnot bitand ] change-state ; inline - -: wait-task ( task -- task ) - WAITBIT state-on ; - -: hold ( task -- task ) - hold-count 1+ to: hold-count - HOLDBIT state-on - link>> ; - -: highest-priority ( t1 t2 -- t1/t2 ) - [ [ pri>> ] bi@ > ] most ; - -: find-tcb ( i -- task ) - task-tab nth [ "Bad task" throw ] unless* ; - -: release ( task i -- task ) - find-tcb HOLDBIT state-off highest-priority ; - -:: qpkt ( task pkt -- task ) - [let | t [ pkt id>> find-tcb ] | - t [ - qpkt-count 1+ to: qpkt-count - f pkt (>>link) - task id>> pkt (>>id) - t wkq>> [ - pkt t wkq>> append-to t (>>wkq) - task - ] [ - pkt t (>>wkq) - t PKTBIT state-on drop - t task highest-priority - ] if - ] [ task ] if - ] ; - -: schedule-waitpkt ( task -- task pkt ) - dup wkq>> - 2dup link>> >>wkq drop - 2dup S_RUNPKT S_RUN ? >>state drop ; inline - -: schedule-run ( task pkt -- task ) - swap fn ; inline - -: schedule-wait ( task -- task ) - link>> ; inline - -: (schedule) ( task -- ) - [ - dup state>> { - { S_WAITPKT [ schedule-waitpkt schedule-run (schedule) ] } - { S_RUN [ f schedule-run (schedule) ] } - { S_RUNPKT [ f schedule-run (schedule) ] } - { S_WAIT [ schedule-wait (schedule) ] } - { S_HOLD [ schedule-wait (schedule) ] } - { S_HOLDPKT [ schedule-wait (schedule) ] } - { S_HOLDWAIT [ schedule-wait (schedule) ] } - { S_HOLDWAITPKT [ schedule-wait (schedule) ] } - [ 2drop ] - } case - ] when* ; - -: schedule ( -- ) - task-list (schedule) ; - -! Device task -TUPLE: device-task < task v1 ; - -: ( id pri wkq -- task ) - dup S_WAITPKT S_WAIT ? device-task new-task ; - -M:: device-task fn ( pkt task -- task ) - pkt [ - task dup v1>> - [ wait-task ] - [ [ f ] change-v1 swap qpkt ] if - ] [ pkt task (>>v1) task hold ] if ; - -TUPLE: handler-task < task workpkts devpkts ; - -: ( id pri wkq -- task ) - dup S_WAITPKT S_WAIT ? handler-task new-task ; - -M:: handler-task fn ( pkt task -- task ) - pkt [ - task over kind>> K_WORK = - [ [ append-to ] change-workpkts ] - [ [ append-to ] change-devpkts ] - if drop - ] when* - - task workpkts>> [ - [let* | devpkt [ task devpkts>> ] - workpkt [ task workpkts>> ] - count [ workpkt a1>> ] | - count BUFSIZE > [ - workpkt link>> task (>>workpkts) - task workpkt qpkt - ] [ - devpkt [ - devpkt link>> task (>>devpkts) - count workpkt a2>> nth devpkt (>>a1) - count 1+ workpkt (>>a1) - task devpkt qpkt - ] [ - task wait-task - ] if - ] if - ] - ] [ task wait-task ] if ; - -! Idle task -TUPLE: idle-task < task { v1 fixnum } { v2 fixnum } ; - -: ( i a1 a2 -- task ) - [ 0 f S_RUN idle-task new-task ] 2dip - [ >>v1 ] [ >>v2 ] bi* ; - -M: idle-task fn ( pkt task -- task ) - nip - [ 1- ] change-v2 - dup v2>> 0 = [ hold ] [ - dup v1>> 1 bitand 0 = [ - [ -1 shift ] change-v1 - I_DEVA release - ] [ - [ -1 shift HEX: d008 bitor ] change-v1 - I_DEVB release - ] if - ] if ; - -! Work task -TUPLE: work-task < task { handler fixnum } { n fixnum } ; - -: ( id pri w -- work-task ) - dup S_WAITPKT S_WAIT ? work-task new-task - I_HANDLERA >>handler - 0 >>n ; - -M:: work-task fn ( pkt task -- task ) - pkt [ - task [ I_HANDLERA = I_HANDLERB I_HANDLERA ? ] change-handler drop - task handler>> pkt (>>id) - 0 pkt (>>a1) - BUFSIZE [| i | - task [ 1+ ] change-n drop - task n>> 26 > [ 1 task (>>n) ] when - task n>> 1 - CHAR: A + i pkt a2>> set-nth - ] each - task pkt qpkt - ] [ task wait-task ] if ; - -! Main -: init ( -- ) - task-tab-size f to: task-tab - f to: tracing - 0 to: hold-count - 0 to: qpkt-count ; - -: start ( -- ) - I_IDLE 1 10000 drop - - I_WORK 1000 - f 0 K_WORK 0 K_WORK - drop - - I_HANDLERA 2000 - f I_DEVA K_DEV - I_DEVA K_DEV - I_DEVA K_DEV - drop - - I_HANDLERB 3000 - f I_DEVB K_DEV - I_DEVB K_DEV - I_DEVB K_DEV - drop - - I_DEVA 4000 f drop - I_DEVB 4000 f drop ; - -: check ( -- ) - qpkt-count 23246 assert= - hold-count 9297 assert= ; - -: run ( -- ) - init - start - schedule check ; diff --git a/unfinished/sql/sql-tests.factor b/unfinished/sql/sql-tests.factor deleted file mode 100644 index 0b57c2d8fa..0000000000 --- a/unfinished/sql/sql-tests.factor +++ /dev/null @@ -1,42 +0,0 @@ -USING: kernel namespaces db.sql sequences math ; -IN: db.sql.tests - -! TUPLE: person name age ; -: insert-1 - { insert - { - { table "person" } - { columns "name" "age" } - { values "erg" 26 } - } - } ; - -: update-1 - { update "person" - { set { "name" "erg" } - { "age" 6 } } - { where { "age" 6 } } - } ; - -: select-1 - { select - { columns - "branchno" - { count "staffno" as "mycount" } - { sum "salary" as "mysum" } } - { from "staff" "lol" } - { where - { "salary" > all - { select - { columns "salary" } - { from "staff" } - { where { "branchno" = "b003" } } - } - } - { "branchno" > 3 } } - { group-by "branchno" "lol2" } - { having { count "staffno" > 1 } } - { order-by "branchno" } - { offset 40 } - { limit 20 } - } ; diff --git a/unfinished/sql/sql.factor b/unfinished/sql/sql.factor deleted file mode 100755 index ba0673ae24..0000000000 --- a/unfinished/sql/sql.factor +++ /dev/null @@ -1,172 +0,0 @@ -USING: kernel parser quotations classes.tuple words math.order -nmake namespaces sequences arrays combinators -prettyprint strings math.parser math symbols db ; -IN: db.sql - -SYMBOLS: insert update delete select distinct columns from as -where group-by having order-by limit offset is-null desc all -any count avg table values ; - -: input-spec, ( obj -- ) 1, ; -: output-spec, ( obj -- ) 2, ; -: input, ( obj -- ) 3, ; -: output, ( obj -- ) 4, ; - -DEFER: sql% - -: (sql-interleave) ( seq sep -- ) - [ sql% ] curry [ sql% ] interleave ; - -: sql-interleave ( seq str sep -- ) - swap sql% (sql-interleave) ; - -: sql-function, ( seq function -- ) - sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; - -: sql-where, ( seq -- ) - [ - [ second 0, ] - [ first 0, ] - [ third 1, \ ? 0, ] tri - ] each ; - -HOOK: sql-create db ( object -- ) -M: db sql-create ( object -- ) - drop - "create table" sql% ; - -HOOK: sql-drop db ( object -- ) -M: db sql-drop ( object -- ) - drop - "drop table" sql% ; - -HOOK: sql-insert db ( object -- ) -M: db sql-insert ( object -- ) - drop - "insert into" sql% ; - -HOOK: sql-update db ( object -- ) -M: db sql-update ( object -- ) - drop - "update" sql% ; - -HOOK: sql-delete db ( object -- ) -M: db sql-delete ( object -- ) - drop - "delete" sql% ; - -HOOK: sql-select db ( object -- ) -M: db sql-select ( object -- ) - "select" sql% "," (sql-interleave) ; - -HOOK: sql-columns db ( object -- ) -M: db sql-columns ( object -- ) - "," (sql-interleave) ; - -HOOK: sql-from db ( object -- ) -M: db sql-from ( object -- ) - "from" "," sql-interleave ; - -HOOK: sql-where db ( object -- ) -M: db sql-where ( object -- ) - "where" 0, sql-where, ; - -HOOK: sql-group-by db ( object -- ) -M: db sql-group-by ( object -- ) - "group by" "," sql-interleave ; - -HOOK: sql-having db ( object -- ) -M: db sql-having ( object -- ) - "having" "," sql-interleave ; - -HOOK: sql-order-by db ( object -- ) -M: db sql-order-by ( object -- ) - "order by" "," sql-interleave ; - -HOOK: sql-offset db ( object -- ) -M: db sql-offset ( object -- ) - "offset" sql% sql% ; - -HOOK: sql-limit db ( object -- ) -M: db sql-limit ( object -- ) - "limit" sql% sql% ; - -! GENERIC: sql-subselect db ( object -- ) -! M: db sql-subselectselect ( object -- ) - ! "(select" sql% sql% ")" sql% ; - -HOOK: sql-table db ( object -- ) -M: db sql-table ( object -- ) - sql% ; - -HOOK: sql-set db ( object -- ) -M: db sql-set ( object -- ) - "set" "," sql-interleave ; - -HOOK: sql-values db ( object -- ) -M: db sql-values ( object -- ) - "values(" sql% "," (sql-interleave) ")" sql% ; - -HOOK: sql-count db ( object -- ) -M: db sql-count ( object -- ) - "count" sql-function, ; - -HOOK: sql-sum db ( object -- ) -M: db sql-sum ( object -- ) - "sum" sql-function, ; - -HOOK: sql-avg db ( object -- ) -M: db sql-avg ( object -- ) - "avg" sql-function, ; - -HOOK: sql-min db ( object -- ) -M: db sql-min ( object -- ) - "min" sql-function, ; - -HOOK: sql-max db ( object -- ) -M: db sql-max ( object -- ) - "max" sql-function, ; - -: sql-array% ( array -- ) - unclip - { - { \ create [ sql-create ] } - { \ drop [ sql-drop ] } - { \ insert [ sql-insert ] } - { \ update [ sql-update ] } - { \ delete [ sql-delete ] } - { \ select [ sql-select ] } - { \ columns [ sql-columns ] } - { \ from [ sql-from ] } - { \ where [ sql-where ] } - { \ group-by [ sql-group-by ] } - { \ having [ sql-having ] } - { \ order-by [ sql-order-by ] } - { \ offset [ sql-offset ] } - { \ limit [ sql-limit ] } - { \ table [ sql-table ] } - { \ set [ sql-set ] } - { \ values [ sql-values ] } - { \ count [ sql-count ] } - { \ sum [ sql-sum ] } - { \ avg [ sql-avg ] } - { \ min [ sql-min ] } - { \ max [ sql-max ] } - [ sql% [ sql% ] each ] - } case ; - -ERROR: no-sql-match ; -: sql% ( obj -- ) - { - { [ dup string? ] [ 0, ] } - { [ dup array? ] [ sql-array% ] } - { [ dup number? ] [ number>string sql% ] } - { [ dup symbol? ] [ unparse sql% ] } - { [ dup word? ] [ unparse sql% ] } - { [ dup quotation? ] [ call ] } - [ no-sql-match ] - } cond ; - -: parse-sql ( obj -- sql in-spec out-spec in out ) - [ [ sql% ] each ] { { } { } { } } nmake - [ " " join ] 2dip ;