-! 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
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
-: primitive-types
+CONSTANT: primitive-types
{
"char" "uchar"
"short" "ushort"
"longlong" "ulonglong"
"float" "double"
"void*" "bool"
- } ;
+ }
[
<c-type>
: (parse-fortran-type) ( fortran-type-string -- type )
parse-out swap parse-dims swap parse-size swap
- dup >lower fortran>c-types at*
- [ nip new-fortran-type ] [ drop misc-type boa ] if ;
+ >lower fortran>c-types ?at
+ [ new-fortran-type ] [ misc-type boa ] if ;
: parse-fortran-type ( fortran-type-string/f -- type/f )
dup [ (parse-fortran-type) ] when ;
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
! Constants
-: image-magic HEX: 0f0e0d0c ; inline
-: image-version 4 ; inline
+CONSTANT: image-magic HEX: 0f0e0d0c
+CONSTANT: image-version 4
-: data-base 1024 ; inline
+CONSTANT: data-base 1024
-: userenv-size 70 ; inline
+CONSTANT: userenv-size 70
-: header-size 10 ; inline
+CONSTANT: header-size 10
-: data-heap-size-offset 3 ; inline
-: t-offset 6 ; inline
-: 0-offset 7 ; inline
-: 1-offset 8 ; inline
-: -1-offset 9 ; inline
+CONSTANT: data-heap-size-offset 3
+CONSTANT: t-offset 6
+CONSTANT: 0-offset 7
+CONSTANT: 1-offset 8
+CONSTANT: -1-offset 9
SYMBOL: sub-primitives
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 )
: month-abbreviation ( n -- string )
check-month 1- month-abbreviations nth ;
-: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
+CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
: day-names ( -- array )
{
timestamp>string\r
] unit-test\r
\r
+[ "20080504070000" ] [\r
+ "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp\r
+ timestamp>mdtm\r
+] unit-test\r
+\r
[\r
T{ timestamp f\r
2008\r
{ gmt-offset T{ duration f 0 0 0 0 0 0 } }\r
}\r
] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test\r
+\r
+\r
M: timestamp year. ( timestamp -- )\r
year>> year. ;\r
\r
+: timestamp>mdtm ( timestamp -- str )\r
+ [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;\r
+\r
: (timestamp>string) ( timestamp -- )\r
{ DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;\r
\r
SINGLETON: adler-32
-: adler-32-modulus 65521 ; inline
+CONSTANT: adler-32-modulus 65521
M: adler-32 checksum-bytes ( bytes checksum -- value )
drop
IN: checksums.openssl
-USING: help.syntax help.markup ;
+USING: checksums help.syntax help.markup ;
HELP: openssl-checksum
{ $class-description "The class of checksum algorithms implemented by OpenSSL. The exact set of algorithms supported depends on how the OpenSSL library was compiled; " { $snippet "md5" } " and " { $snippet "sha1" } " should be universally available." } ;
{ $description "Creates a new OpenSSL checksum object." } ;
HELP: openssl-md5
+{ $values { "value" checksum } }
{ $description "The OpenSSL MD5 message digest implementation." } ;
HELP: openssl-sha1
+{ $values { "value" checksum } }
{ $description "The OpenSSL SHA1 message digest implementation." } ;
HELP: unknown-digest
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
SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
-: a 0 ; inline
-: b 1 ; inline
-: c 2 ; inline
-: d 3 ; inline
-: e 4 ; inline
-: f 5 ; inline
-: g 6 ; inline
-: h 7 ; inline
+CONSTANT: a 0
+CONSTANT: b 1
+CONSTANT: c 2
+CONSTANT: d 3
+CONSTANT: e 4
+CONSTANT: f 5
+CONSTANT: g 6
+CONSTANT: h 7
: initial-H-256 ( -- seq )
{
] 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
dup 0 -> setCanChooseDirectories:
dup 0 -> setAllowsMultipleSelection: ;
-: NSOKButton 1 ;
-: NSCancelButton 0 ;
+CONSTANT: NSOKButton 1
+CONSTANT: NSCancelButton 0
: open-panel ( -- paths )
<NSOpenPanel>
specialized-arrays.direct.alien ;
IN: cocoa.enumeration
-: NS-EACH-BUFFER-SIZE 16 ; inline
+CONSTANT: NS-EACH-BUFFER-SIZE 16
: with-enumeration-buffers ( quot -- )
[
-! 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 )
: sender-stub ( method function -- word )
[ "( sender-stub )" f <word> dup ] 2dip
over first large-struct? [ "_stret" append ] when
- make-sender define ;
+ make-sender dup infer define-declared ;
SYMBOL: message-senders
SYMBOL: super-message-senders
core-foundation.strings core-foundation.arrays ;
IN: cocoa.pasteboard
-: NSStringPboardType "NSStringPboardType" ;
+CONSTANT: NSStringPboardType "NSStringPboardType"
: pasteboard-string? ( pasteboard -- ? )
NSStringPboardType swap -> types CF>string-array member? ;
{ "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 ) ;
] 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 )
[
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 ;
-
-: kCGLRendererGenericFloatID HEX: 00020400 ;
+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
+
+CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
<PRIVATE
USE: opengl.gl
USE: alien.syntax
-: NSOpenGLCPSwapInterval 222 ;
+CONSTANT: NSOpenGLCPSwapInterval 222
LIBRARY: OpenGL
sequences math.bitwise ;
IN: cocoa.windows
-: NSBorderlessWindowMask 0 ; inline
-: NSTitledWindowMask 1 ; inline
-: NSClosableWindowMask 2 ; inline
-: NSMiniaturizableWindowMask 4 ; inline
-: NSResizableWindowMask 8 ; inline
+CONSTANT: NSBorderlessWindowMask 0
+CONSTANT: NSTitledWindowMask 1
+CONSTANT: NSClosableWindowMask 2
+CONSTANT: NSMiniaturizableWindowMask 4
+CONSTANT: NSResizableWindowMask 8
-: NSBackingStoreRetained 0 ; inline
-: NSBackingStoreNonretained 1 ; inline
-: NSBackingStoreBuffered 2 ; inline
+CONSTANT: NSBackingStoreRetained 0
+CONSTANT: NSBackingStoreNonretained 1
+CONSTANT: NSBackingStoreBuffered 2
: standard-window-type ( -- n )
{
M: color green>> ( color -- green ) >rgba green>> ;
M: color blue>> ( color -- blue ) >rgba blue>> ;
-: black T{ rgba f 0.0 0.0 0.0 1.0 } ; inline
-: blue T{ rgba f 0.0 0.0 1.0 1.0 } ; inline
-: cyan T{ rgba f 0 0.941 0.941 1 } ; inline
-: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; inline
-: green T{ rgba f 0.0 1.0 0.0 1.0 } ; inline
-: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; inline
-: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; inline
-: magenta T{ rgba f 0.941 0 0.941 1 } ; inline
-: orange T{ rgba f 0.941 0.627 0 1 } ; inline
-: purple T{ rgba f 0.627 0 0.941 1 } ; inline
-: red T{ rgba f 1.0 0.0 0.0 1.0 } ; inline
-: white T{ rgba f 1.0 1.0 1.0 1.0 } ; inline
-: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; inline
+CONSTANT: black T{ rgba f 0.0 0.0 0.0 1.0 }
+CONSTANT: blue T{ rgba f 0.0 0.0 1.0 1.0 }
+CONSTANT: cyan T{ rgba f 0 0.941 0.941 1 }
+CONSTANT: gray T{ rgba f 0.6 0.6 0.6 1.0 }
+CONSTANT: green T{ rgba f 0.0 1.0 0.0 1.0 }
+CONSTANT: light-gray T{ rgba f 0.95 0.95 0.95 0.95 }
+CONSTANT: light-purple T{ rgba f 0.8 0.8 1.0 1.0 }
+CONSTANT: magenta T{ rgba f 0.941 0 0.941 1 }
+CONSTANT: orange T{ rgba f 0.941 0.627 0 1 }
+CONSTANT: purple T{ rgba f 0.627 0 0.941 1 }
+CONSTANT: red T{ rgba f 1.0 0.0 0.0 1.0 }
+CONSTANT: white T{ rgba f 1.0 1.0 1.0 1.0 }
+CONSTANT: yellow T{ rgba f 1.0 1.0 0.0 1.0 }
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?
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
{ $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"
-"Factor is a fully compiled language implementation with two distinct compilers:"
+"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
+$nl
+"The two compilers differ in the level of analysis they perform:"
{ $list
{ "The " { $emphasis "non-optimizing quotation compiler" } " compiles quotations to naive machine code very quickly. The non-optimizing quotation compiler is part of the VM." }
{ "The " { $emphasis "optimizing word compiler" } " compiles whole words at a time while performing extensive data and control flow analysis. This provides greater performance for generated code, but incurs a much longer compile time. The optimizing compiler is written in Factor." }
}
-"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
-{ $subsection "compiler-usage" }
+"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
+$nl
+"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
{ $subsection "compiler-errors" }
-{ $subsection "hints" } ;
+{ $subsection "hints" }
+{ $subsection "compiler-usage" } ;
ABOUT: "compiler"
{ $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." } ;
! 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 -- )
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.
save-asm
] each ;
-: finish ( effect word -- )
- [ swap save-effect ]
+: finish ( word -- )
+ [ +optimized+ save-compiled-status ]
[ compiled-unxref ]
[
dup crossref?
: decompile ( word -- )
f 2array 1array modify-code-heap ;
+: compile-call ( quot -- )
+ [ dup infer define-temp ] with-compilation-unit execute ;
+
: optimized-recompile-hook ( words -- alist )
[
<hashed-dlist> compile-queue set
IN: compiler.constants
! These constants must match vm/memory.h
-: card-bits 8 ; inline
-: deck-bits 18 ; inline
+CONSTANT: card-bits 8
+CONSTANT: deck-bits 18
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
! These constants must match vm/layouts.h
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
-: rc-absolute-cell 0 ; inline
-: rc-absolute 1 ; inline
-: rc-relative 2 ; inline
-: rc-absolute-ppc-2/2 3 ; inline
-: rc-relative-ppc-2 4 ; inline
-: rc-relative-ppc-3 5 ; inline
-: rc-relative-arm-3 6 ; inline
-: rc-indirect-arm 7 ; inline
-: rc-indirect-arm-pc 8 ; inline
+CONSTANT: rc-absolute-cell 0
+CONSTANT: rc-absolute 1
+CONSTANT: rc-relative 2
+CONSTANT: rc-absolute-ppc-2/2 3
+CONSTANT: rc-relative-ppc-2 4
+CONSTANT: rc-relative-ppc-3 5
+CONSTANT: rc-relative-arm-3 6
+CONSTANT: rc-indirect-arm 7
+CONSTANT: rc-indirect-arm-pc 8
! Relocation types
-: rt-primitive 0 ; inline
-: rt-dlsym 1 ; inline
-: rt-dispatch 2 ; inline
-: rt-xt 3 ; inline
-: rt-here 4 ; inline
-: rt-label 5 ; inline
-: rt-immediate 6 ; inline
-: rt-stack-chain 7 ; inline
+CONSTANT: rt-primitive 0
+CONSTANT: rt-dlsym 1
+CONSTANT: rt-dispatch 2
+CONSTANT: rt-xt 3
+CONSTANT: rt-here 4
+CONSTANT: rt-label 5
+CONSTANT: rt-immediate 6
+CONSTANT: rt-stack-chain 7
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
\ foo [ global >n get ndrop ] compile-call
] unit-test
-: blech drop ;
+: blech ( x -- ) drop ;
[ 3 ]
[
[ ] [
[
[ 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
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
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
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
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.
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 )
! regression
-: literal-not-branch 0 not [ ] [ ] if ;
+: literal-not-branch ( -- ) 0 not [ ] [ ] if ;
[ ] [ literal-not-branch ] unit-test
[ 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
] 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
USE: binary-search
USE: binary-search.private
-: old-binsearch ( elt quot seq -- elt quot i )
+: old-binsearch ( elt quot: ( -- ) seq -- elt quot i )
dup length 1 <= [
from>>
] [
[ midpoint swap call ] 3keep roll dup zero?
[ drop dup from>> swap midpoint@ + ]
- [ dup midpoint@ cut-slice old-binsearch ] if
- ] if ; inline
+ [ drop dup midpoint@ head-slice old-binsearch ] if
+ ] if ; inline recursive
[ 10 ] [
10 20 >vector <flat-slice>
[ 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
] [
] [
[ [ 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
: 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
--- /dev/null
+IN: compiler.tests
+USING: peg.ebnf strings tools.test ;
+
+GENERIC: <times> ( times -- term' )
+M: string <times> ;
+
+EBNF: parse-regexp
+
+Times = .* => [[ "foo" ]]
+
+Regexp = Times:t => [[ t <times> ]]
+
+;EBNF
+
+[ "foo" ] [ "a" parse-regexp ] unit-test
\ No newline at end of file
[ "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
! Labels
-: recursive-test ( ? -- ) [ f recursive-test ] when ; inline
+: recursive-test ( ? -- ) [ f recursive-test ] when ; inline recursive
[ ] [ t [ recursive-test ] compile-call ] unit-test
IN: compiler.tests
-USING: kernel tools.test compiler.units ;
+USING: kernel tools.test compiler.units compiler ;
TUPLE: color red green blue ;
: 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
: 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 )
: 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 )
[
[
{
] unit-test
! A reduction
-: buffalo-sauce f ;
+: buffalo-sauce ( -- value ) f ;
: steak ( -- )
buffalo-sauce [ steak ] when ; inline recursive
[ { array } declare 2 <groups> [ . . ] assoc-each ]
\ nth-unsafe inlined?
] unit-test
+
+[ t ] [
+ [ { fixnum fixnum } declare = ]
+ \ both-fixnums? inlined?
+] unit-test
\ No newline at end of file
! 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 )
{
: 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
length
slots ;
-: null-info T{ value-info f null empty-interval } ; inline
+CONSTANT: null-info T{ value-info f null empty-interval }
-: object-info T{ value-info f object full-interval } ; inline
+CONSTANT: object-info T{ value-info f object full-interval }
: class-interval ( class -- interval )
dup real class<=
] "outputs" set-word-prop
\ both-fixnums? [
- [ class>> fixnum classes-intersect? not ] either?
- f <literal-info> object-info ?
+ [ class>> ] bi@ {
+ { [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
+ { [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
+ [ object-info ]
+ } cond 2nip
] "outputs" set-word-prop
{
] contains-node?
] unit-test
-: blah f ;
+: blah ( -- value ) f ;
DEFER: a
: omega-k-in-table? ( lzw -- ? )
[ omega-k>> ] [ table>> ] bi key? ;
-ERROR: not-in-table ;
+ERROR: not-in-table value ;
: write-output ( lzw -- )
[
- [ omega>> ] [ table>> ] bi at* [ not-in-table ] unless
+ [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless
] [
[ lzw-bit-width-compress ]
[ output>> write-bits ] bi
TYPEDEF: void* CFTypeRef
TYPEDEF: void* CFAllocatorRef
-: kCFAllocatorDefault f ; inline
+CONSTANT: kCFAllocatorDefault f
TYPEDEF: bool Boolean
TYPEDEF: long CFIndex
TYPEDEF: void* CFSetRef
TYPEDEF: int CFNumberType
-: kCFNumberSInt8Type 1 ; inline
-: kCFNumberSInt16Type 2 ; inline
-: kCFNumberSInt32Type 3 ; inline
-: kCFNumberSInt64Type 4 ; inline
-: kCFNumberFloat32Type 5 ; inline
-: kCFNumberFloat64Type 6 ; inline
-: kCFNumberCharType 7 ; inline
-: kCFNumberShortType 8 ; inline
-: kCFNumberIntType 9 ; inline
-: kCFNumberLongType 10 ; inline
-: kCFNumberLongLongType 11 ; inline
-: kCFNumberFloatType 12 ; inline
-: kCFNumberDoubleType 13 ; inline
-: kCFNumberCFIndexType 14 ; inline
-: kCFNumberNSIntegerType 15 ; inline
-: kCFNumberCGFloatType 16 ; inline
-: kCFNumberMaxType 16 ; inline
+CONSTANT: kCFNumberSInt8Type 1
+CONSTANT: kCFNumberSInt16Type 2
+CONSTANT: kCFNumberSInt32Type 3
+CONSTANT: kCFNumberSInt64Type 4
+CONSTANT: kCFNumberFloat32Type 5
+CONSTANT: kCFNumberFloat64Type 6
+CONSTANT: kCFNumberCharType 7
+CONSTANT: kCFNumberShortType 8
+CONSTANT: kCFNumberIntType 9
+CONSTANT: kCFNumberLongType 10
+CONSTANT: kCFNumberLongLongType 11
+CONSTANT: kCFNumberFloatType 12
+CONSTANT: kCFNumberDoubleType 13
+CONSTANT: kCFNumberCFIndexType 14
+CONSTANT: kCFNumberNSIntegerType 15
+CONSTANT: kCFNumberCGFloatType 16
+CONSTANT: kCFNumberMaxType 16
TYPEDEF: int CFPropertyListMutabilityOptions
-: kCFPropertyListImmutable 0 ; inline
-: kCFPropertyListMutableContainers 1 ; inline
-: kCFPropertyListMutableContainersAndLeaves 2 ; inline
+CONSTANT: kCFPropertyListImmutable 0
+CONSTANT: kCFPropertyListMutableContainers 1
+CONSTANT: kCFPropertyListMutableContainersAndLeaves 2
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
CFFileDescriptorContext* context
) ;
-: kCFFileDescriptorReadCallBack 1 ; inline
-: kCFFileDescriptorWriteCallBack 2 ; inline
+CONSTANT: kCFFileDescriptorReadCallBack 1
+CONSTANT: kCFFileDescriptorWriteCallBack 2
FUNCTION: void CFFileDescriptorEnableCallBacks (
CFFileDescriptorRef f,
core-foundation.time ;
IN: core-foundation.fsevents
-: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
-: kFSEventStreamCreateFlagWatchRoot 4 ; inline
-
-: kFSEventStreamEventFlagMustScanSubDirs 1 ; inline
-: kFSEventStreamEventFlagUserDropped 2 ; inline
-: kFSEventStreamEventFlagKernelDropped 4 ; inline
-: kFSEventStreamEventFlagEventIdsWrapped 8 ; inline
-: kFSEventStreamEventFlagHistoryDone 16 ; inline
-: kFSEventStreamEventFlagRootChanged 32 ; inline
-: kFSEventStreamEventFlagMount 64 ; inline
-: kFSEventStreamEventFlagUnmount 128 ; inline
+CONSTANT: kFSEventStreamCreateFlagUseCFTypes 2
+CONSTANT: kFSEventStreamCreateFlagWatchRoot 4
+
+CONSTANT: kFSEventStreamEventFlagMustScanSubDirs 1
+CONSTANT: kFSEventStreamEventFlagUserDropped 2
+CONSTANT: kFSEventStreamEventFlagKernelDropped 4
+CONSTANT: kFSEventStreamEventFlagEventIdsWrapped 8
+CONSTANT: kFSEventStreamEventFlagHistoryDone 16
+CONSTANT: kFSEventStreamEventFlagRootChanged 32
+CONSTANT: kFSEventStreamEventFlagMount 64
+CONSTANT: kFSEventStreamEventFlagUnmount 128
TYPEDEF: int FSEventStreamCreateFlags
TYPEDEF: int FSEventStreamEventFlags
! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
TYPEDEF: void* FSEventStreamCallback
-: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF ; inline
+CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
FUNCTION: FSEventStreamRef FSEventStreamCreate (
CFAllocatorRef allocator,
core-foundation.time ;
IN: core-foundation.run-loop
-: kCFRunLoopRunFinished 1 ; inline
-: kCFRunLoopRunStopped 2 ; inline
-: kCFRunLoopRunTimedOut 3 ; inline
-: kCFRunLoopRunHandledSource 4 ; inline
+CONSTANT: kCFRunLoopRunFinished 1
+CONSTANT: kCFRunLoopRunStopped 2
+CONSTANT: kCFRunLoopRunTimedOut 3
+CONSTANT: kCFRunLoopRunHandledSource 4
TYPEDEF: void* CFRunLoopRef
TYPEDEF: void* CFRunLoopSourceRef
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,
core-foundation ;
IN: core-foundation.urls
-: kCFURLPOSIXPathStyle 0 ; inline
+CONSTANT: kCFURLPOSIXPathStyle 0
TYPEDEF: void* CFURLRef
{ double-float-regs T{ range f 0 29 1 } }
} ;
-: scratch-reg 28 ; inline
-: fp-scratch-reg 30 ; inline
+CONSTANT: scratch-reg 28
+CONSTANT: fp-scratch-reg 30
M: ppc two-operand? f ;
M: ppc %alien-global ( register symbol dll -- )
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
-: ds-reg 29 ; inline
-: rs-reg 30 ; inline
+CONSTANT: ds-reg 29
+CONSTANT: rs-reg 30
GENERIC: loc-reg ( loc -- reg )
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations destructors kernel math
namespaces sequences classes.tuple words strings
-tools.walker accessors combinators fry ;
+tools.walker accessors combinators fry db.errors ;
IN: db
-<PRIVATE
-
TUPLE: db-connection
handle
insert-statements
update-statements
delete-statements ;
+<PRIVATE
+
: new-db-connection ( class -- obj )
new
H{ } clone >>insert-statements
GENERIC: db-open ( db -- db-connection )
HOOK: db-close db-connection ( handle -- )
+HOOK: parse-db-error db-connection ( error -- error' )
: dispose-statements ( assoc -- ) values dispose-each ;
GENERIC: execute-statement* ( statement type -- )
M: object execute-statement* ( statement type -- )
- drop query-results dispose ;
+ '[
+ _ _ drop query-results dispose
+ ] [
+ parse-db-error rethrow
+ ] recover ;
: execute-one-statement ( statement -- )
dup type>> execute-statement* ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: accessors kernel continuations fry words ;
IN: db.errors
ERROR: db-error ;
-ERROR: sql-error ;
+ERROR: sql-error location ;
-ERROR: table-exists ;
ERROR: bad-schema ;
+
+ERROR: sql-unknown-error < sql-error message ;
+: <sql-unknown-error> ( message -- error )
+ \ sql-unknown-error new
+ swap >>message ;
+
+ERROR: sql-table-exists < sql-error table ;
+: <sql-table-exists> ( table -- error )
+ \ sql-table-exists new
+ swap >>table ;
+
+ERROR: sql-table-missing < sql-error table ;
+: <sql-table-missing> ( table -- error )
+ \ sql-table-missing new
+ swap >>table ;
+
+ERROR: sql-syntax-error < sql-error message ;
+: <sql-syntax-error> ( message -- error )
+ \ sql-syntax-error new
+ swap >>message ;
+
+ERROR: sql-function-exists < sql-error message ;
+: <sql-function-exists> ( message -- error )
+ \ sql-function-exists new
+ swap >>message ;
+
+ERROR: sql-function-missing < sql-error message ;
+: <sql-function-missing> ( message -- error )
+ \ sql-function-missing new
+ swap >>message ;
+
+: ignore-error ( quot word -- )
+ '[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline
+
+: ignore-table-exists ( quot -- )
+ \ sql-table-exists? ignore-error ; inline
+
+: ignore-table-missing ( quot -- )
+ \ sql-table-missing? ignore-error ; inline
+
+: ignore-function-exists ( quot -- )
+ \ sql-function-exists? ignore-error ; inline
+
+: ignore-function-missing ( quot -- )
+ \ sql-function-missing? ignore-error ; inline
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit db db.errors
+db.errors.postgresql db.postgresql io.files.unique kernel namespaces
+tools.test db.tester continuations ;
+IN: db.errors.postgresql.tests
+
+[
+
+ [ "drop table foo;" sql-command ] ignore-errors
+ [ "drop table ship;" sql-command ] ignore-errors
+
+ [
+ "insert into foo (id) values('1');" sql-command
+ ] [
+ { [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
+ ] must-fail-with
+
+ [
+ "create table ship(id integer);" sql-command
+ "create table ship(id integer);" sql-command
+ ] [
+ { [ sql-table-exists? ] [ table>> "ship" = ] } 1&&
+ ] must-fail-with
+
+ [
+ "create table foo(id) lol;" sql-command
+ ] [
+ sql-syntax-error?
+ ] must-fail-with
+
+] test-postgresql
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel db.errors peg.ebnf strings sequences math
+combinators.short-circuit accessors math.parser quoting ;
+IN: db.errors.postgresql
+
+EBNF: parse-postgresql-sql-error
+
+Error = "ERROR:" [ ]+
+
+TableError =
+ Error ("relation "|"table ")(!(" already exists").)+:table " already exists"
+ => [[ table >string unquote <sql-table-exists> ]]
+ | Error ("relation "|"table ")(!(" does not exist").)+:table " does not exist"
+ => [[ table >string unquote <sql-table-missing> ]]
+
+FunctionError =
+ Error "function" (!(" already exists").)+:table " already exists"
+ => [[ table >string <sql-function-exists> ]]
+ | Error "function" (!(" does not exist").)+:table " does not exist"
+ => [[ table >string <sql-function-missing> ]]
+
+SyntaxError =
+ Error "syntax error at end of input":error
+ => [[ error >string <sql-syntax-error> ]]
+ | Error "syntax error at or near " .+:syntaxerror
+ => [[ syntaxerror >string unquote <sql-syntax-error> ]]
+
+UnknownError = .* => [[ >string <sql-unknown-error> ]]
+
+PostgresqlSqlError = (TableError | FunctionError | SyntaxError | UnknownError)
+
+;EBNF
+
+
+ERROR: parse-postgresql-location column line text ;
+C: <parse-postgresql-location> parse-postgresql-location
+
+EBNF: parse-postgresql-line-error
+
+Line = "LINE " [0-9]+:line ": " .+:sql
+ => [[ f line >string string>number sql >string <parse-postgresql-location> ]]
+
+;EBNF
+
+:: set-caret-position ( error caret-line -- error )
+ caret-line length
+ error line>> number>string length "LINE : " length +
+ - [ error ] dip >>column ;
+
+: postgresql-location ( line column -- obj )
+ [ parse-postgresql-line-error ] dip
+ set-caret-position ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit db db.errors
+db.errors.sqlite db.sqlite io.files.unique kernel namespaces
+tools.test ;
+IN: db.errors.sqlite.tests
+
+: sqlite-error-test-db-path ( -- path )
+ "sqlite" "error-test" make-unique-file ;
+
+sqlite-error-test-db-path <sqlite-db> [
+
+ [
+ "insert into foo (id) values('1');" sql-command
+ ] [
+ { [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
+ ] must-fail-with
+
+ [
+ "create table foo(id);" sql-command
+ "create table foo(id);" sql-command
+ ] [
+ { [ sql-table-exists? ] [ table>> "foo" = ] } 1&&
+ ] must-fail-with
+
+] with-db
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db kernel sequences peg.ebnf
+strings db.errors ;
+IN: db.errors.sqlite
+
+ERROR: unparsed-sqlite-error error ;
+
+SINGLETONS: table-exists table-missing ;
+
+: sqlite-table-error ( table message -- error )
+ {
+ { table-exists [ <sql-table-exists> ] }
+ } case ;
+
+EBNF: parse-sqlite-sql-error
+
+TableMessage = " already exists" => [[ table-exists ]]
+
+SqliteError =
+ "table " (!(TableMessage).)+:table TableMessage:message
+ => [[ table >string message sqlite-table-error ]]
+ | "no such table: " .+:table
+ => [[ table >string <sql-table-missing> ]]
+;EBNF
USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db db.private
-db.tuples db.types unicode.case accessors system ;
+db.tuples db.types unicode.case accessors system db.tester ;
IN: db.postgresql.tests
-: test-db ( -- postgresql-db )
- <postgresql-db>
- "localhost" >>host
- "postgres" >>username
- "thepasswordistrust" >>password
- "factor-test" >>database ;
-
os windows? cpu x86.64? and [
- [ ] [ test-db [ ] with-db ] unit-test
+ [ ] [ postgresql-test-db [ ] with-db ] unit-test
[ ] [
- test-db [
+ postgresql-test-db [
[ "drop table person;" sql-command ] ignore-errors
"create table person (name varchar(30), country varchar(30));"
sql-command
{ "Jane" "New Zealand" }
}
] [
- test-db [
+ postgresql-test-db [
"select * from person" sql-query
] with-db
] unit-test
{ "John" "America" }
{ "Jane" "New Zealand" }
}
- ] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+ ] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
[
] [
- test-db [
+ postgresql-test-db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-db
{ "Jane" "New Zealand" }
{ "Jimmy" "Canada" }
}
- ] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+ ] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
[
- test-db [
+ postgresql-test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
] must-fail
[ 3 ] [
- test-db [
+ postgresql-test-db [
"select * from person" sql-query length
] with-db
] unit-test
[
] [
- test-db [
+ postgresql-test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] unit-test
[ 5 ] [
- test-db [
+ postgresql-test-db [
"select * from person" sql-query length
] with-db
] unit-test
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators classes locals words tools.walker db.private
-nmake accessors random db.queries destructors db.tuples.private ;
-USE: tools.walker
+nmake accessors random db.queries destructors db.tuples.private
+db.postgresql db.errors.postgresql splitting ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty database username password ;
{ "references" [ >reference-string ] }
[ drop no-compound-found ]
} case ;
+
+M: postgresql-db-connection parse-db-error
+ "\n" split dup length {
+ { 1 [ first parse-postgresql-sql-error ] }
+ { 3 [
+ first3
+ [ parse-postgresql-sql-error ] 2dip
+ postgresql-location >>location
+ ] }
+ } case ;
+
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
io.backend db.errors present urls io.encodings.utf8
-io.encodings.string accessors shuffle io prettyprint
-db.private ;
+io.encodings.string accessors shuffle io db.private ;
IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
ERROR: sqlite-sql-error < sql-error n string ;
+: <sqlite-sql-error> ( n string -- error )
+ \ sqlite-sql-error new
+ swap >>string
+ swap >>n ;
+
: throw-sqlite-error ( n -- * )
dup sqlite-error-messages nth sqlite-error ;
: sqlite-statement-error ( -- * )
SQLITE_ERROR
- db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
+ db-connection get handle>> sqlite3_errmsg <sqlite-sql-error> throw ;
: sqlite-check-result ( n -- )
{
] if* (sqlite-bind-type) ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
-: sqlite-reset ( handle -- )
-"resetting: " write dup . sqlite3_reset sqlite-check-result ;
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
: sqlite-clear-bindings ( handle -- )
sqlite3_clear_bindings sqlite-check-result ;
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
USING: io io.files io.files.temp io.directories io.launcher
kernel namespaces prettyprint tools.test db.sqlite db sequences
-continuations db.types db.tuples unicode.case ;
+continuations db.types db.tuples unicode.case accessors arrays
+sorting ;
IN: db.sqlite.tests
: db-path ( -- path ) "test.db" temp-file ;
] with-db
] unit-test
+[ \ swap ensure-table ] must-fail
+
! You don't need a primary key
-USING: accessors arrays sorting ;
TUPLE: things one two ;
things "THINGS" {
1 <foo> insert-tuple
f <foo> select-tuple
1 1 <hi> insert-tuple
- f <hi> select-tuple
+ f f <hi> select-tuple
hi drop-table
foo drop-table
] with-db
] unit-test
-[ ] [
- test.db [
- hi create-table
- hi drop-table
- ] with-db
-] unit-test
+
+! Test SQLite triggers
TUPLE: show id ;
TUPLE: user username data ;
} define-persistent
watch "WATCH" {
- { "user" "USER" TEXT +not-null+
- { +foreign-id+ user "USERNAME" } +user-assigned-id+ }
- { "show" "SHOW" BIG-INTEGER +not-null+
- { +foreign-id+ show "ID" } +user-assigned-id+ }
+ { "user" "USER" TEXT +not-null+ +user-assigned-id+
+ { +foreign-id+ user "USERNAME" } }
+ { "show" "SHOW" BIG-INTEGER +not-null+ +user-assigned-id+
+ { +foreign-id+ show "ID" } }
} define-persistent
-
+
[ T{ user { username "littledan" } { data "foo" } } ] [
test.db [
user create-table
show new insert-tuple
show new select-tuple
"littledan" f user boa select-tuple
+ [ id>> ] [ username>> ] bi*
watch boa insert-tuple
watch new select-tuple
user>> f user boa select-tuple
] with-db
] unit-test
-
-[ \ swap ensure-table ] must-fail
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs classes compiler db hashtables
-io.files kernel math math.parser namespaces prettyprint
+io.files kernel math math.parser namespaces prettyprint fry
sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string multiline make db.private ;
+io.streams.string multiline make db.private sequences.deep
+db.errors.sqlite ;
IN: db.sqlite
TUPLE: sqlite-db path ;
dup handle>> sqlite-result-set new-result-set
dup advance-row ;
-M: sqlite-db-connection create-sql-statement ( class -- statement )
- [
- dupd
- "create table " 0% 0%
- "(" 0% [ ", " 0% ] [
- dup "sql-spec" set
- dup column-name>> [ "table-id" set ] [ 0% ] bi
- " " 0%
- dup type>> lookup-create-type 0%
- modifiers 0%
- ] interleave
-
- find-primary-key [
- ", " 0%
- "primary key(" 0%
- [ "," 0% ] [ column-name>> 0% ] interleave
- ")" 0%
- ] unless-empty
- ");" 0%
- ] query-make ;
-
-M: sqlite-db-connection drop-sql-statement ( class -- statement )
- [ "drop table " 0% 0% ";" 0% drop ] query-make ;
-
M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
[
"insert into " 0% 0%
: insert-trigger ( -- string )
[
<"
- CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
+ SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
: insert-trigger-not-null ( -- string )
[
<"
- CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
- WHERE NEW.${foreign-table-id} IS NOT NULL
+ SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
+ WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
: update-trigger ( -- string )
[
<"
- CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
- WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
: update-trigger-not-null ( -- string )
[
<"
- CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
- WHERE NEW.${foreign-table-id} IS NOT NULL
+ SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
+ WHERE NEW.${table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
: delete-trigger-restrict ( -- string )
[
<"
- CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
- WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
+ SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END;
"> interpolate
] with-string-writer ;
: delete-trigger-cascade ( -- string )
[
<"
- CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
delete-trigger-restrict sqlite-trigger,
] if ;
+: create-db-triggers ( sql-specs -- )
+ [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
+ [
+ [ class>> db-table-name "db-table" set ]
+ [
+ [ "sql-spec" set ]
+ [ column-name>> "table-id" set ]
+ [ ] tri
+ modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
+ [
+ [ second db-table-name "foreign-table-name" set ]
+ [ third "foreign-table-id" set ] bi
+ create-sqlite-triggers
+ ] each
+ ] bi
+ ] each ;
+
+: sqlite-create-table ( sql-specs class-name -- )
+ [
+ "create table " 0% 0%
+ "(" 0% [ ", " 0% ] [
+ dup "sql-spec" set
+ dup column-name>> [ "table-id" set ] [ 0% ] bi
+ " " 0%
+ dup type>> lookup-create-type 0%
+ modifiers 0%
+ ] interleave
+ ] [
+ drop
+ find-primary-key [
+ ", " 0%
+ "primary key(" 0%
+ [ "," 0% ] [ column-name>> 0% ] interleave
+ ")" 0%
+ ] unless-empty
+ ");" 0%
+ ] 2bi ;
+
+M: sqlite-db-connection create-sql-statement ( class -- statement )
+ [
+ [ sqlite-create-table ]
+ [ drop create-db-triggers ] 2bi
+ ] query-make ;
+
+M: sqlite-db-connection drop-sql-statement ( class -- statements )
+ [ nip "drop table " 0% 0% ";" 0% ] query-make ;
+
M: sqlite-db-connection compound ( string seq -- new-string )
over {
{ "default" [ first number>string " " glue ] }
- { "references" [
- [ >reference-string ] keep
- first2 [ db-table-name "foreign-table-name" set ]
- [ "foreign-table-id" set ] bi*
- create-sqlite-triggers
- ] }
+ { "references" [ >reference-string ] }
[ 2drop ]
} case ;
+
+M: sqlite-db-connection parse-db-error
+ dup n>> {
+ { 1 [ string>> parse-sqlite-sql-error ] }
+ [ drop ]
+ } case ;
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.combinators db.pools db.sqlite db.tuples
db.types kernel math random threads tools.test db sequences
-io prettyprint ;
+io prettyprint db.postgresql db.sqlite accessors io.files.temp
+namespaces fry system ;
IN: db.tester
+: postgresql-test-db ( -- postgresql-db )
+ <postgresql-db>
+ "localhost" >>host
+ "postgres" >>username
+ "thepasswordistrust" >>password
+ "factor-test" >>database ;
+
+: sqlite-test-db ( -- sqlite-db )
+ "tuples-test.db" temp-file <sqlite-db> ;
+
+
+! These words leak resources, but are useful for interactivel testing
+: set-sqlite-db ( -- )
+ sqlite-db db-open db-connection set ;
+
+: set-postgresql-db ( -- )
+ postgresql-db db-open db-connection set ;
+
+
+: test-sqlite ( quot -- )
+ '[
+ [ ] [ sqlite-test-db _ with-db ] unit-test
+ ] call ; inline
+
+: test-postgresql ( quot -- )
+ '[
+ os windows? cpu x86.64? and [
+ [ ] [ postgresql-test-db _ with-db ] unit-test
+ ] unless
+ ] call ; inline
+
+
TUPLE: test-1 id a b c ;
test-1 "TEST1" {
{ "z" "Z" { VARCHAR 256 } +not-null+ }
} define-persistent
-: sqlite-test-db ( -- db ) "test.db" <sqlite-db> ;
-: test-db ( -- db ) "test.db" <sqlite-db> ;
-
: db-tester ( test-db -- )
[
[
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise system
-math.ranges strings urls fry db.tuples.private db.private ;
+math.ranges strings urls fry db.tuples.private db.private
+db.tester ;
IN: db.tuples.tests
-: sqlite-db ( -- sqlite-db )
- "tuples-test.db" temp-file <sqlite-db> ;
-
-: test-sqlite ( quot -- )
- '[
- [ ] [
- "tuples-test.db" temp-file <sqlite-db> _ with-db
- ] unit-test
- ] call ; inline
-
-: postgresql-db ( -- postgresql-db )
- <postgresql-db>
- "localhost" >>host
- "postgres" >>username
- "thepasswordistrust" >>password
- "factor-test" >>database ;
-
-: test-postgresql ( quot -- )
- '[
- os windows? cpu x86.64? and [
- [ ] [ postgresql-db _ with-db ] unit-test
- ] unless
- ] call ; inline
-
-! These words leak resources, but are useful for interactivel testing
-: sqlite-test-db ( -- )
- sqlite-db db-open db-connection set ;
-
-: postgresql-test-db ( -- )
- postgresql-db db-open db-connection set ;
-
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob url ;
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
-destructors mirrors sets db.types db.private ;
+destructors mirrors sets db.types db.private fry
+combinators.short-circuit db.errors ;
IN: db.tuples
HOOK: create-sql-statement db-connection ( class -- object )
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
rot class new [
- [ [ slot-name>> ] dip set-slot-named ] curry 2each
+ '[ slot-name>> _ set-slot-named ] 2each
] keep ;
: query-tuples ( exemplar-tuple statement -- seq )
M: tuple >query <query> swap >>tuple ;
+ERROR: no-defined-persistent object ;
+
+: ensure-defined-persistent ( object -- object )
+ dup { [ class? ] [ "db-table" word-prop ] } 1&& [
+ no-defined-persistent
+ ] unless ;
+
: create-table ( class -- )
+ ensure-defined-persistent
create-sql-statement [ execute-statement ] with-disposals ;
: drop-table ( class -- )
+ ensure-defined-persistent
drop-sql-statement [ execute-statement ] with-disposals ;
: recreate-table ( class -- )
+ ensure-defined-persistent
[
- [ drop-sql-statement [ execute-statement ] with-disposals
- ] curry ignore-errors
+ '[
+ [
+ _ drop-sql-statement [ execute-statement ] with-disposals
+ ] ignore-table-missing
+ ] ignore-function-missing
] [ create-table ] bi ;
-: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
+: ensure-table ( class -- )
+ ensure-defined-persistent
+ '[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
: ensure-tables ( classes -- ) [ ensure-table ] each ;
: insert-tuple ( tuple -- )
- dup class db-columns find-primary-key db-assigned-id-spec?
+ dup class ensure-defined-persistent
+ db-columns find-primary-key db-assigned-id-spec?
[ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
: update-tuple ( tuple -- )
- dup class
+ dup class ensure-defined-persistent
db-connection get update-statements>> [ <update-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: delete-tuples ( tuple -- )
- dup dup class <delete-tuples-statement> [
+ dup
+ dup class ensure-defined-persistent
+ <delete-tuples-statement> [
[ bind-tuple ] keep execute-statement
] with-disposal ;
>query [ tuple>> ] [ query>statement ] bi do-select ;
: select-tuple ( query/tuple -- tuple/f )
- >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
- [ f ] [ first ] if-empty ;
+ >query 1 >>limit [ tuple>> ] [ query>statement ] bi
+ do-select [ f ] [ first ] if-empty ;
: count-tuples ( query/tuple -- n )
>query [ tuple>> ] [ <count-statement> ] bi do-count
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
-: ?at ( obj assoc -- value/obj ? )
- dupd at* [ [ nip ] [ drop ] if ] keep ;
-
ERROR: unknown-modifier modifier ;
: lookup-modifier ( obj -- string )
: editpadlite-path ( -- path )
\ editpadlite-path get-global [
- "JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
+ "JGsoft" [ >lower "editpadlite.exe" tail? ] find-in-program-files
[ "editpadlite.exe" ] unless*
] unless* ;
: editpadpro-path ( -- path )
\ editpadpro-path get-global [
- "JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
+ "JGsoft" [ >lower "editpadpro.exe" tail? ] find-in-program-files
[ "editpadpro.exe" ] unless*
] unless* ;
: editplus-path ( -- path )
\ editplus-path get-global [
- "EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
+ "EditPlus 2" [ "editplus.exe" tail? ] find-in-program-files
[ "editplus.exe" ] unless*
] unless* ;
USING: definitions io.launcher kernel parser words sequences math
-math.parser namespaces editors make system ;
+math.parser namespaces editors make system combinators.short-circuit
+fry threads vocabs.loader ;
IN: editors.emacs
+SYMBOL: emacsclient-path
+
+HOOK: default-emacsclient os ( -- path )
+
+M: object default-emacsclient ( -- path ) "emacsclient" ;
+
: emacsclient ( file line -- )
[
- \ emacsclient get "emacsclient" or ,
- os windows? [ "--no-wait" , ] unless
- "+" swap number>string append ,
+ { [ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
+ "--no-wait" ,
+ number>string "+" prepend ,
,
- ] { } make try-process ;
+ ] { } make
+ os windows? [ run-detached drop ] [ try-process ] if ;
: emacs ( word -- )
where first2 emacsclient ;
[ emacsclient ] edit-hook set-global
+os windows? [ "editors.emacs.windows" require ] when
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: editors.emacs io.directories.search.windows kernel sequences
+system combinators.short-circuit ;
+IN: editors.emacs.windows
+
+M: windows default-emacsclient
+ {
+ [ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ]
+ [ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ]
+ [ "emacsclient.exe" ]
+ } 0|| ;
: emeditor-path ( -- path )
\ emeditor-path get-global [
- "EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
+ "EmEditor" [ "EmEditor.exe" tail? ] find-in-program-files
[ "EmEditor.exe" ] unless*
] unless* ;
: etexteditor-path ( -- str )
\ etexteditor-path get-global [
- "e" t [ "e.exe" tail? ] find-in-program-files
+ "e" [ "e.exe" tail? ] find-in-program-files
[ "e" ] unless*
] unless* ;
M: windows gvim-path
\ gvim-path get-global [
- "vim" t [ "gvim.exe" tail? ] find-in-program-files
+ "vim" [ "gvim.exe" tail? ] find-in-program-files
[ "gvim.exe" ] unless*
] unless* ;
: notepadpp-path ( -- path )
\ notepadpp-path get-global [
- "notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
+ "notepad++" [ "notepad++.exe" tail? ] find-in-program-files
[ "notepad++.exe" ] unless*
] unless* ;
: scite-path ( -- path )
\ scite-path get-global [
- "Scintilla Text Editor" t
+ "Scintilla Text Editor"
[ >lower "scite.exe" tail? ] find-in-program-files
[
- "SciTE Source Code Editor" t
+ "SciTE Source Code Editor"
[ >lower "scite.exe" tail? ] find-in-program-files
] unless*
[ "scite.exe" ] unless*
: ted-notepad-path ( -- path )
\ ted-notepad-path get-global [
- "TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
+ "TED Notepad" [ "TedNPad.exe" tail? ] find-in-program-files
[ "TedNPad.exe" ] unless*
] unless* ;
: textpad-path ( -- path )
\ textpad-path get-global [
- "TextPad 5" t [ "TextPad.exe" tail? ] find-in-program-files
+ "TextPad 5" [ "TextPad.exe" tail? ] find-in-program-files
[ "TextPad.exe" ] unless*
] unless* ;
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
- "IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
+ "IDM Computer Solutions" [ "uedit32.exe" tail? ] find-in-program-files
[ "uedit32.exe" ] unless*
] unless* ;
: wordpad-path ( -- path )
\ wordpad-path get [
- "Windows NT\\Accessories" t
+ "Windows NT\\Accessories"
[ "wordpad.exe" tail? ] find-in-program-files
] unless* ;
= (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' )
{
: ensure-login ( url -- url )
dup username>> [
"anonymous" >>username
- "ftp-client" >>password
+ "ftp-client@factorcode.org" >>password
] unless ;
: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
math.parser sequences strings ;
IN: ftp
-SINGLETON: active
-SINGLETON: passive
+SYMBOLS: +active+ +passive+ ;
TUPLE: ftp-response n strings parsed ;
over strings>> push ;
: ftp-send ( string -- ) write "\r\n" write flush ;
-: ftp-ipv4 1 ; inline
-: ftp-ipv6 2 ; inline
--- /dev/null
+USING: calendar ftp.server io.encodings.ascii io.files
+io.files.unique namespaces threads tools.test kernel
+io.servers.connection ftp.client accessors urls
+io.pathnames io.directories sequences fry ;
+IN: ftp.server.tests
+
+: test-file-contents ( -- string )
+ "Files are so boring anymore." ;
+
+: create-test-file ( -- path )
+ test-file-contents
+ "ftp.server" "test" make-unique-file
+ [ ascii set-file-contents ] keep canonicalize-path ;
+
+: test-ftp-server ( quot -- )
+ '[
+ current-temporary-directory get 0
+ <ftp-server>
+ [ start-server* ]
+ [
+ sockets>> first addr>> port>>
+ <url>
+ swap >>port
+ "ftp" >>protocol
+ "localhost" >>host
+ create-test-file >>path
+ _ call
+ ]
+ [ stop-server ] tri
+ ] with-unique-directory drop ; inline
+
+[ t ]
+[
+
+ [
+ unique-directory [
+ [ ftp-get ] [ path>> file-name ascii file-contents ] bi
+ ] with-directory
+ ] test-ftp-server test-file-contents =
+] unit-test
+
+[
+
+ [
+ "/" >>path
+ unique-directory [
+ [ ftp-get ] [ path>> file-name ascii file-contents ] bi
+ ] with-directory
+ ] test-ftp-server test-file-contents =
+] must-fail
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit accessors combinators io
-io.encodings.8-bit io.encodings io.encodings.binary
-io.encodings.utf8 io.files io.files.info io.directories
-io.sockets kernel math.parser namespaces make sequences
-ftp io.launcher.unix.parser unicode.case splitting
-assocs classes io.servers.connection destructors calendar
-io.timeouts io.streams.duplex threads continuations math
-concurrency.promises byte-arrays io.backend tools.hexdump
-io.streams.string math.bitwise tools.files io.pathnames ;
+USING: accessors assocs byte-arrays calendar classes
+combinators combinators.short-circuit concurrency.promises
+continuations destructors ftp io io.backend io.directories
+io.encodings io.encodings.8-bit io.encodings.binary
+tools.files io.encodings.utf8 io.files io.files.info
+io.pathnames io.launcher.unix.parser io.servers.connection
+io.sockets io.streams.duplex io.streams.string io.timeouts
+kernel make math math.bitwise math.parser namespaces sequences
+splitting threads unicode.case logging calendar.format
+strings io.files.links io.files.types ;
IN: ftp.server
-TUPLE: ftp-client url mode state command-promise user password ;
-
-: <ftp-client> ( url -- ftp-client )
- ftp-client new
- swap >>url ;
-
+SYMBOL: server
SYMBOL: client
-: ftp-server-directory ( -- str )
- \ ftp-server-directory get-global "resource:temp" or
- normalize-path ;
+TUPLE: ftp-server < threaded-server { serving-directory string } ;
-TUPLE: ftp-command raw tokenized ;
+TUPLE: ftp-client user password extra-connection ;
-: <ftp-command> ( -- obj )
- ftp-command new ;
+TUPLE: ftp-command raw tokenized ;
+: <ftp-command> ( str -- obj )
+ dup \ <ftp-command> DEBUG log-message
+ ftp-command new
+ over >>raw
+ swap tokenize-command >>tokenized ;
TUPLE: ftp-get path ;
-
: <ftp-get> ( path -- obj )
ftp-get new
swap >>path ;
TUPLE: ftp-put path ;
-
: <ftp-put> ( path -- obj )
ftp-put new
swap >>path ;
TUPLE: ftp-list ;
-
C: <ftp-list> ftp-list
-: read-command ( -- ftp-command )
- <ftp-command> readln
- [ >>raw ] [ tokenize-command >>tokenized ] bi ;
+TUPLE: ftp-disconnect ;
+C: <ftp-disconnect> ftp-disconnect
: (send-response) ( n string separator -- )
[ number>string write ] 2dip write ftp-send ;
[ but-last-slice [ "-" (send-response) ] with each ]
[ first " " (send-response) ] 2bi ;
-: server-response ( n string -- )
+: server-response ( string n -- )
+ 2dup number>string swap ":" glue \ server-response DEBUG log-message
<ftp-response>
- swap add-response-line
swap >>n
+ swap add-response-line
send-response ;
-: ftp-error ( string -- )
- 500 "Unrecognized command: " rot append server-response ;
+: serving? ( path -- ? )
+ canonicalize-path server get serving-directory>> head? ;
+
+: can-serve-directory? ( path -- ? )
+ { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
+
+: can-serve-file? ( path -- ? )
+ {
+ [ exists? ]
+ [ file-info type>> +regular-file+ = ]
+ [ serving? ]
+ } 1&& ;
+
+: ftp-error ( string -- ) 500 server-response ;
+: ftp-unimplemented ( string -- ) 502 server-response ;
: send-banner ( -- )
- 220 "Welcome to " host-name append server-response ;
+ "Welcome to " host-name append 220 server-response ;
: anonymous-only ( -- )
- 530 "This FTP server is anonymous only." server-response ;
+ "This FTP server is anonymous only." 530 server-response ;
: handle-QUIT ( obj -- )
- drop 221 "Goodbye." server-response ;
+ drop "Goodbye." 221 server-response ;
: handle-USER ( ftp-command -- )
[
tokenized>> second client get (>>user)
- 331 "Please specify the password." server-response
+ "Please specify the password." 331 server-response
] [
2drop "bad USER" ftp-error
] recover ;
: handle-PASS ( ftp-command -- )
[
tokenized>> second client get (>>password)
- 230 "Login successful" server-response
+ "Login successful" 230 server-response
] [
2drop "PASS error" ftp-error
] recover ;
: handle-TYPE ( obj -- )
[
tokenized>> second parse-type
- [ 200 ] dip "Switching to " " mode" surround server-response
+ "Switching to " " mode" surround 200 server-response
] [
2drop "TYPE is binary only" ftp-error
] recover ;
: handle-PWD ( obj -- )
drop
- 257 current-directory get "\"" dup surround server-response ;
+ current-directory get "\"" dup surround 257 server-response ;
: handle-SYST ( obj -- )
drop
- 215 "UNIX Type: L8" server-response ;
+ "UNIX Type: L8" 215 server-response ;
-: if-command-promise ( quot -- )
- [ client get command-promise>> ] dip
- [ "Establish an active or passive connection first" ftp-error ] if* ;
+: start-directory ( -- )
+ "Here comes the directory listing." 150 server-response ;
-: handle-STOR ( obj -- )
- [
- tokenized>> second
- [ [ <ftp-put> ] dip fulfill ] if-command-promise
- ] [
- 2drop
- ] recover ;
+: transfer-outgoing-file ( path -- )
+ [ "Opening BINARY mode data connection for " ] dip
+ [ file-name ] [
+ file-info size>> number>string
+ "(" " bytes)." surround
+ ] bi " " glue append 150 server-response ;
-! EPRT |2|::1|62138|
-! : handle-EPRT ( obj -- )
- ! tokenized>> second "|" split harvest ;
+: transfer-incoming-file ( path -- )
+ "Opening BINARY mode data connection for " prepend
+ 150 server-response ;
-: start-directory ( -- )
- 150 "Here comes the directory listing." server-response ;
+: finish-file-transfer ( -- )
+ "File send OK." 226 server-response ;
-: finish-directory ( -- )
- 226 "Directory send OK." server-response ;
+GENERIC: handle-passive-command ( stream obj -- )
+
+: passive-loop ( server -- )
+ [
+ [
+ |dispose
+ 30 seconds over set-timeout
+ accept drop &dispose
+ client get extra-connection>>
+ 30 seconds ?promise-timeout
+ handle-passive-command
+ ]
+ [ client get f >>extra-connection drop ]
+ [ drop ] cleanup
+ ] with-destructors ;
-GENERIC: service-command ( stream obj -- )
+: finish-directory ( -- )
+ "Directory send OK." 226 server-response ;
-M: ftp-list service-command ( stream obj -- )
+M: ftp-list handle-passive-command ( stream obj -- )
drop
start-directory [
utf8 encode-output
[ current-directory get directory. ] with-string-writer string-lines
harvest [ ftp-send ] each
- ] with-output-stream
- finish-directory ;
+ ] with-output-stream finish-directory ;
-: transfer-outgoing-file ( path -- )
- [
- 150
- "Opening BINARY mode data connection for "
- ] dip
- [
- file-name
- ] [
- file-info size>> number>string
- "(" " bytes)." surround
- ] bi " " glue append server-response ;
-
-: transfer-incoming-file ( path -- )
- [ 150 ] dip "Opening BINARY mode data connection for " prepend
- server-response ;
-
-: finish-file-transfer ( -- )
- 226 "File send OK." server-response ;
-
-M: ftp-get service-command ( stream obj -- )
+M: ftp-get handle-passive-command ( stream obj -- )
[
path>>
[ transfer-outgoing-file ]
3drop "File transfer failed" ftp-error
] recover ;
-M: ftp-put service-command ( stream obj -- )
+M: ftp-put handle-passive-command ( stream obj -- )
[
path>>
[ transfer-incoming-file ]
3drop "File transfer failed" ftp-error
] recover ;
-: passive-loop ( server -- )
- [
- [
- |dispose
- 30 seconds over set-timeout
- accept drop &dispose
- client get command-promise>>
- 30 seconds ?promise-timeout
- service-command
- ]
- [ client get f >>command-promise drop ]
- [ drop ] cleanup
- ] with-destructors ;
+M: ftp-disconnect handle-passive-command ( stream obj -- )
+ drop dispose ;
-: handle-LIST ( obj -- )
- drop
- [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
+: fulfill-client ( obj -- )
+ client get extra-connection>> [
+ fulfill
+ ] [
+ drop
+ "Establish an active or passive connection first" ftp-error
+ ] if* ;
-: handle-SIZE ( obj -- )
- [
- [ 213 ] dip
- tokenized>> second file-info size>>
- number>string server-response
+: handle-STOR ( obj -- )
+ tokenized>> second
+ dup can-serve-file? [
+ <ftp-put> fulfill-client
] [
- 2drop
- 550 "Could not get file size" server-response
- ] recover ;
+ drop
+ <ftp-disconnect> fulfill-client
+ ] if ;
+
+: handle-LIST ( obj -- )
+ drop current-directory get
+ can-serve-directory? [
+ <ftp-list> fulfill-client
+ ] [
+ <ftp-disconnect> fulfill-client
+ ] if ;
+
+: not-a-plain-file ( path -- )
+ ": not a plain file." append ftp-error ;
: handle-RETR ( obj -- )
- [ tokenized>> second <ftp-get> swap fulfill ]
- curry if-command-promise ;
+ tokenized>> second
+ dup can-serve-file? [
+ <ftp-get> fulfill-client
+ ] [
+ not-a-plain-file
+ <ftp-disconnect> fulfill-client
+ ] if ;
+
+: handle-SIZE ( obj -- )
+ tokenized>> second
+ dup can-serve-file? [
+ file-info size>> number>string 213 server-response
+ ] [
+ not-a-plain-file
+ ] if ;
: expect-connection ( -- port )
+ <promise> client get (>>extra-connection)
random-local-server
- client get <promise> >>command-promise drop
[ [ passive-loop ] curry in-thread ]
[ addr>> port>> ] bi ;
: handle-PASV ( obj -- )
- drop client get passive >>mode drop
- 221
+ drop
expect-connection port>bytes [ number>string ] bi@ "," glue
"Entering Passive Mode (127,0,0,1," ")" surround
- server-response ;
+ 221 server-response ;
: handle-EPSV ( obj -- )
drop
- client get command-promise>> [
- "You already have a passive stream" ftp-error
+ client get f >>extra-connection drop
+ expect-connection number>string
+ "Entering Extended Passive Mode (|||" "|)" surround
+ 229 server-response ;
+
+: handle-MDTM ( obj -- )
+ tokenized>> 1 swap ?nth [
+ dup file-info dup directory? [
+ drop not-a-plain-file
+ ] [
+ nip
+ modified>> timestamp>mdtm
+ 213 server-response
+ ] if
] [
- 229
- expect-connection number>string
- "Entering Extended Passive Mode (|||" "|)" surround
- server-response
- ] if ;
-
-! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
-! : handle-LPRT ( obj -- ) tokenized>> "," split ;
+ "" not-a-plain-file
+ ] if* ;
ERROR: not-a-directory ;
-ERROR: no-permissions ;
+ERROR: no-directory-permissions ;
-: handle-CWD ( obj -- )
- [
- tokenized>> second dup normalize-path
- dup ftp-server-directory head? [
- no-permissions
- ] unless
+: directory-change-success ( -- )
+ "Directory successully changed." 250 server-response ;
+
+: directory-change-failed ( -- )
+ "Failed to change directory." 553 server-response ;
- file-info directory? [
+: handle-CWD ( obj -- )
+ tokenized>> 1 swap ?nth [
+ dup can-serve-directory? [
set-current-directory
- 250 "Directory successully changed." server-response
+ directory-change-success
] [
- not-a-directory
+ drop
+ directory-change-failed
] if
] [
- 2drop
- 550 "Failed to change directory." server-response
- ] recover ;
+ directory-change-success
+ ] if* ;
-: unrecognized-command ( obj -- ) raw>> ftp-error ;
+: unrecognized-command ( obj -- )
+ raw>> "Unrecognized command: " prepend ftp-error ;
-: handle-client-loop ( -- )
- <ftp-command> readln
- USE: prettyprint global [ dup . flush ] bind
- [ >>raw ]
- [ tokenize-command >>tokenized ] bi
+: client-loop-dispatch ( str/f -- ? )
dup tokenized>> first >upper {
+ { "QUIT" [ handle-QUIT f ] }
{ "USER" [ handle-USER t ] }
{ "PASS" [ handle-PASS t ] }
- { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
+ { "SYST" [ handle-SYST t ] }
+ { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] }
+ { "PWD" [ handle-PWD t ] }
+ { "TYPE" [ handle-TYPE t ] }
{ "CWD" [ handle-CWD t ] }
- ! { "XCWD" [ ] }
- ! { "CDUP" [ ] }
- ! { "SMNT" [ ] }
-
- ! { "REIN" [ drop client get reset-ftp-client t ] }
- { "QUIT" [ handle-QUIT f ] }
-
- ! { "PORT" [ ] } ! TODO
{ "PASV" [ handle-PASV t ] }
- ! { "MODE" [ ] }
- { "TYPE" [ handle-TYPE t ] }
- ! { "STRU" [ ] }
-
- ! { "ALLO" [ ] }
- ! { "REST" [ ] }
+ { "EPSV" [ handle-EPSV t ] }
+ { "LIST" [ handle-LIST t ] }
{ "STOR" [ handle-STOR t ] }
- ! { "STOU" [ ] }
{ "RETR" [ handle-RETR t ] }
- { "LIST" [ handle-LIST t ] }
{ "SIZE" [ handle-SIZE t ] }
- ! { "NLST" [ ] }
- ! { "APPE" [ ] }
- ! { "RNFR" [ ] }
- ! { "RNTO" [ ] }
- ! { "DELE" [ handle-DELE t ] }
- ! { "RMD" [ handle-RMD t ] }
- ! ! { "XRMD" [ handle-XRMD t ] }
- ! { "MKD" [ handle-MKD t ] }
- { "PWD" [ handle-PWD t ] }
- ! { "ABOR" [ ] }
-
- { "SYST" [ handle-SYST t ] }
- ! { "STAT" [ ] }
- ! { "HELP" [ ] }
+ { "MDTM" [ handle-MDTM t ] }
+ [ drop unrecognized-command t ]
+ } case ;
- ! { "SITE" [ ] }
- ! { "NOOP" [ ] }
+: read-command ( -- ftp-command/f )
+ readln [ f ] [ <ftp-command> ] if-empty ;
- ! { "EPRT" [ handle-EPRT ] }
- ! { "LPRT" [ handle-LPRT ] }
- { "EPSV" [ handle-EPSV t ] }
- ! { "LPSV" [ drop handle-LPSV t ] }
- [ drop unrecognized-command t ]
- } case [ handle-client-loop ] when ;
+: handle-client-loop ( -- )
+ read-command [
+ client-loop-dispatch
+ [ handle-client-loop ] when
+ ] when* ;
-TUPLE: ftp-server < threaded-server ;
+: serve-directory ( server -- )
+ serving-directory>> [
+ send-banner
+ handle-client-loop
+ ] with-directory ;
M: ftp-server handle-client* ( server -- )
- drop
[
- ftp-server-directory [
- host-name <ftp-client> client set
- send-banner handle-client-loop
- ] with-directory
+ "New client" \ handle-client* DEBUG log-message
+ ftp-client new client set
+ [ server set ] [ serve-directory ] bi
] with-destructors ;
-: <ftp-server> ( port -- server )
+: <ftp-server> ( directory port -- server )
ftp-server new-threaded-server
swap >>insecure
+ swap canonicalize-path >>serving-directory
"ftp.server" >>name
5 minutes >>timeout
latin1 >>encoding ;
-: ftpd ( port -- )
+: ftpd ( directory port -- )
<ftp-server> start-server ;
-: ftpd-main ( -- ) 2100 ftpd ;
+: ftpd-main ( path -- ) 2100 ftpd ;
MAIN: ftpd-main
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
: param ( name -- value )\r
params get at ;\r
\r
-: revalidate-url-key "__u" ;\r
+CONSTANT: revalidate-url-key "__u"\r
\r
: revalidate-url ( -- url/f )\r
revalidate-url-key param\r
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
{ "post-data" "POST_DATA" FACTOR-BLOB }
} define-persistent
-: aside-id-key "__a" ;
+CONSTANT: aside-id-key "__a"
TUPLE: asides < server-state-manager ;
\r
PRIVATE>\r
\r
-: flashed-variables { description capabilities } ;\r
+CONSTANT: flashed-variables { description capabilities }\r
\r
: login-failed ( -- * )\r
"invalid username or password" validation-error\r
USING: furnace.auth.providers kernel ;\r
IN: furnace.auth.providers.null\r
\r
-TUPLE: no-users ;\r
-\r
-: no-users T{ no-users } ;\r
+SINGLETON: no-users\r
\r
M: no-users get-user 2drop f ;\r
\r
{ "session" "SESSION" BIG-INTEGER +not-null+ }
} define-persistent
-: conversation-id-key "__c" ;
+CONSTANT: conversation-id-key "__c"
TUPLE: conversations < server-state-manager ;
[ 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?>> [
[XML <input type="hidden" value=<-> name=<->/> XML]
] [ drop ] if ;
-: nested-forms-key "__n" ;
+CONSTANT: nested-forms-key "__n"
: request-params ( request -- assoc )
dup method>> {
SYMBOL: exit-continuation
-: exit-with ( value -- )
+: exit-with ( value -- * )
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )
"io"
} ;
-ARTICLE: "cookbook-compiler" "Compiler cookbook"
-"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is a fully transparent process. However, there are a few things worth knowing about the compilation process."
-$nl
-"The optimizing compiler trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
-$nl
-"After loading a vocabulary, you might see messages like:"
-{ $code
- ":errors - print 2 compiler errors."
- ":warnings - print 50 compiler warnings."
-}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
-{ $references
- "To learn more about the compiler and static stack effect inference, read these articles:"
- "compiler"
- "compiler-errors"
- "inference"
-} ;
-
ARTICLE: "cookbook-application" "Application cookbook"
"Vocabularies can define a main entry point:"
{ $code "IN: game-of-life"
{ $subsection "cookbook-io" }
{ $subsection "cookbook-application" }
{ $subsection "cookbook-scripts" }
-{ $subsection "cookbook-compiler" }
{ $subsection "cookbook-philosophy" }
{ $subsection "cookbook-pitfalls" }
{ $subsection "cookbook-next" } ;
{ { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } }
{ { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } }
{ { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }
- { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } }
- { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } }
+ { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } }
+ { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } }
{ { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-input-stream with-output-stream } }
{ { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } }
}
drop "Help article does not exist" ;
: article ( name -- article )
- dup articles get at* [ nip ] [ drop no-article ] if ;
+ articles get ?at [ no-article ] unless ;
M: object article-name article article-name ;
M: object article-title article article-title ;
{ string string }
"specializer" set-word-prop
-\ find-last-sep { string sbuf } "specializer" set-word-prop
-
\ >string { sbuf } "specializer" set-word-prop
\ >array { { vector } } "specializer" set-word-prop
: 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 = ;
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
+: bytes-per-pixel ( component-order -- n )
+ {
+ { BGR [ 3 ] }
+ { RGB [ 3 ] }
+ { BGRA [ 4 ] }
+ { RGBA [ 4 ] }
+ { ABGR [ 4 ] }
+ { ARGB [ 4 ] }
+ { RGBX [ 4 ] }
+ { XRGB [ 4 ] }
+ { BGRX [ 4 ] }
+ { XBGR [ 4 ] }
+ { R16G16B16 [ 6 ] }
+ { R32G32B32 [ 12 ] }
+ { R16G16B16A16 [ 8 ] }
+ { R32G32B32A32 [ 16 ] }
+ } case ;
+
TUPLE: image dim component-order bitmap ;
: <image> ( -- image ) image new ; inline
: normalize-image ( image -- image )
[ >byte-array ] change-bitmap
normalize-component-order
- normalize-scan-line-order ;
+ normalize-scan-line-order ;
\ No newline at end of file
ERROR: no-tag class ;
-: ?at ( key assoc -- value/key ? )
- dupd at* [ nip t ] [ drop f ] if ; inline
-
: find-tag ( idf class -- tag )
swap processed-tags>> ?at [ no-tag ] unless ;
'[ handle>> _ wait-for-fd ] with-timeout ;
! Some general stuff
-: file-mode OCT: 0666 ;
+CONSTANT: file-mode OCT: 0666
! Readers
: (refill) ( port -- n )
HELP: find-all-files
{ $values
- { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
+ { "path" "a pathname string" } { "quot" quotation }
{ "paths/f" "a sequence of pathname strings or f" }
}
{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ;
[ t ] [
[
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
- current-temporary-directory get t [ ] find-all-files
+ current-temporary-directory get [ ] find-all-files
] with-unique-directory drop [ natural-sort ] bi@ =
] unit-test
[ keep and ] curry iterate-directory
] [ drop f ] recover ; inline
-: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths/f )
+: find-all-files ( path quot: ( obj -- ? ) -- paths/f )
+ f swap
'[
_ _ _ [ <directory-iterator> ] dip
pusher [ [ f ] compose iterate-directory drop ] dip
] [ drop f ] recover ; inline
+ERROR: file-not-found ;
+
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
- '[ _ _ find-file ] attempt-all ;
+ [
+ '[ _ _ find-file [ file-not-found ] unless* ] attempt-all
+ ] [
+ drop f
+ ] recover ;
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
'[ _ _ find-all-files ] map concat ;
: program-files-directories ( -- array )
program-files program-files-x86 2array harvest ; inline
-: find-in-program-files ( base-directory bfs? quot -- path )
- [
+: find-in-program-files ( base-directory quot -- path )
+ t swap [
[ program-files-directories ] dip '[ _ append-path ] map
] 2dip find-in-directories ; inline
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
<PRIVATE
-: mappings {
+CONSTANT: mappings {
! encoding-name iana-name file-name
{ "latin1" "ISO_8859-1:1987" "8859-1" }
{ "latin2" "ISO_8859-2:1987" "8859-2" }
{ "windows-1252" "windows-1252" "CP1252" }
{ "ebcdic" "IBM037" "CP037" }
{ "mac-roman" "macintosh" "ROMAN" }
-} ;
+}
: encoding-file ( file-name -- stream )
- "vocab:io/encodings/8-bit/" swap ".TXT"
- 3append ;
+ "vocab:io/encodings/8-bit/" ".TXT" surround ;
: process-contents ( lines -- assoc )
[ "#" split1 drop ] map harvest
: byte>ch ( assoc -- array )
256 replacement-char <array>
- [ [ swapd set-nth ] curry assoc-each ] keep ;
+ [ '[ swap _ set-nth ] assoc-each ] keep ;
: ch>byte ( assoc -- newassoc )
[ swap ] assoc-map >hashtable ;
--- /dev/null
+! Copyright (C) 2009 Yun, Jonghyouk.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup ;
+IN: io.encodings.korean
+
+ARTICLE: "io.encodings.korean" "Korean text encodings"
+"The " { $vocab-link "io.encodings.korean" } " vocabulary implements encodings used for Korean text besides the standard UTF encodings for Unicode strings."
+{ $subsection cp949 } ;
+
+ABOUT: "io.encodings.korean"
+
+HELP: cp949
+{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR. " }
+{ $see-also "encodings-introduction" } ;
values hashtables io.binary ;
IN: io.encodings.korean
+! TODO: migrate to common code-table parser (by Dan).
+
SINGLETON: cp949
cp949 "EUC-KR" register-encoding
] map ;
: (find-mount-point) ( path mtab-paths -- mtab-entry )
- [ follow-links ] dip 2dup at* [
+ 2dup at* [
2nip
] [
drop [ parent-directory ] dip (find-mount-point)
] if ;
: find-mount-point ( path -- mtab-entry )
+ canonicalize-path
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
ERROR: file-system-not-found ;
PRIVATE>
-: UID OCT: 0004000 ; inline
-: GID OCT: 0002000 ; inline
-: STICKY OCT: 0001000 ; inline
-: USER-ALL OCT: 0000700 ; inline
-: USER-READ OCT: 0000400 ; inline
-: USER-WRITE OCT: 0000200 ; inline
-: USER-EXECUTE OCT: 0000100 ; inline
-: GROUP-ALL OCT: 0000070 ; inline
-: GROUP-READ OCT: 0000040 ; inline
-: GROUP-WRITE OCT: 0000020 ; inline
-: GROUP-EXECUTE OCT: 0000010 ; inline
-: OTHER-ALL OCT: 0000007 ; inline
-: OTHER-READ OCT: 0000004 ; inline
-: OTHER-WRITE OCT: 0000002 ; inline
-: OTHER-EXECUTE OCT: 0000001 ; inline
+CONSTANT: UID OCT: 0004000
+CONSTANT: GID OCT: 0002000
+CONSTANT: STICKY OCT: 0001000
+CONSTANT: USER-ALL OCT: 0000700
+CONSTANT: USER-READ OCT: 0000400
+CONSTANT: USER-WRITE OCT: 0000200
+CONSTANT: USER-EXECUTE OCT: 0000100
+CONSTANT: GROUP-ALL OCT: 0000070
+CONSTANT: GROUP-READ OCT: 0000040
+CONSTANT: GROUP-WRITE OCT: 0000020
+CONSTANT: GROUP-EXECUTE OCT: 0000010
+CONSTANT: OTHER-ALL OCT: 0000007
+CONSTANT: OTHER-READ OCT: 0000004
+CONSTANT: OTHER-WRITE OCT: 0000002
+CONSTANT: OTHER-EXECUTE OCT: 0000001
: uid? ( obj -- ? ) UID file-mode? ;
: gid? ( obj -- ? ) GID file-mode? ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend io.files.links system unix ;
+USING: io.backend io.files.links system unix io.pathnames kernel
+io.files sequences ;
IN: io.files.links.unix
M: unix make-link ( path1 path2 -- )
M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ;
+
+M: unix canonicalize-path ( path -- path' )
+ path-components "/"
+ [ append-path dup exists? [ follow-links ] when ] reduce ;
USING: io io.mmap io.mmap.char io.files io.files.temp
io.directories kernel tools.test continuations sequences
-io.encodings.ascii accessors ;
+io.encodings.ascii accessors math ;
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
+
+
+[ "mmap-empty-file.txt" temp-file delete-file ] ignore-errors
+[ ] [ "mmap-empty-file.txt" temp-file touch-file ] unit-test
+
+[
+ "mmap-empty-file.txt" temp-file [
+ drop
+ ] with-mapped-file
+] [ bad-mmap-size? ] must-fail-with
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors io.files io.files.info
io.backend kernel quotations system alien alien.accessors
-accessors system vocabs.loader combinators alien.c-types ;
+accessors system vocabs.loader combinators alien.c-types
+math ;
IN: io.mmap
TUPLE: mapped-file address handle length disposed ;
HOOK: (mapped-file) os ( path length -- address handle )
+ERROR: bad-mmap-size path size ;
+
: <mapped-file> ( path -- mmap )
- [ normalize-path ] [ file-info size>> ] bi [ (mapped-file) ] keep
+ [ normalize-path ] [ file-info size>> ] bi
+ dup 0 <= [ bad-mmap-size ] when
+ [ (mapped-file) ] keep
f mapped-file boa ;
HOOK: close-mapped-file io-backend ( mmap -- )
:: mmap-open ( path length prot flags -- alien fd )
[
f length prot flags
- path open-r/w |dispose
+ path open-r/w [ <fd> |dispose drop ] keep
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
] with-destructors ;
TUPLE: threaded-server
name
+log-level
secure insecure
secure-config
sockets
: new-threaded-server ( class -- threaded-server )
new
"server" >>name
+ DEBUG >>log-level
ascii >>encoding
1 minutes >>timeout
V{ } clone >>sockets
: (start-server) ( threaded-server -- )
init-server
dup threaded-server [
- dup name>> [
+ [ ] [ name>> ] bi [
[ listen-on [ start-accept-loop ] parallel-each ]
[ ready>> raise-flag ]
bi
+++ /dev/null
-IN: io.servers.datagram
-
-<PRIVATE
-
-LOG: received-datagram NOTICE
-
-: datagram-loop ( quot datagram -- )
- [
- [ receive dup received-datagram [ swap call ] dip ] keep
- pick [ send ] [ 3drop ] if
- ] 2keep datagram-loop ; inline
-
-: spawn-datagrams ( quot addrspec -- )
- <datagram> [ datagram-loop ] with-disposal ; inline
-
-\ spawn-datagrams NOTICE add-input-logging
-
-PRIVATE>
-
-: with-datagrams ( seq service quot -- )
- '[ [ [ _ ] dip spawn-datagrams ] parallel-each ] with-logging ; inline
--- /dev/null
+USING: concurrency.combinators destructors fry
+io.sockets kernel logging ;
+IN: io.servers.packet
+
+<PRIVATE
+
+LOG: received-datagram NOTICE
+
+: datagram-loop ( quot datagram -- )
+ [
+ [ receive dup received-datagram [ swap call ] dip ] keep
+ pick [ send ] [ 3drop ] if
+ ] 2keep datagram-loop ; inline
+
+: spawn-datagrams ( quot addrspec -- )
+ <datagram> [ datagram-loop ] with-disposal ; inline
+
+\ spawn-datagrams NOTICE add-input-logging
+
+PRIVATE>
+
+: with-datagrams ( seq service quot -- )
+ '[ [ [ _ ] dip spawn-datagrams ] parallel-each ] with-logging ; inline
SYMBOL: receive-buffer
-: packet-size 65536 ; inline
+CONSTANT: packet-size 65536
[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
+! Copyright (C) 2008, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces io.encodings.private accessors ;
+sequences io namespaces io.encodings.private accessors sequences.private
+io.streams.sequence destructors ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
[ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
dup encoder? [ stream>> ] when >byte-array ; inline
+TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
+
+M: byte-reader stream-read-partial stream-read ;
+M: byte-reader stream-read sequence-read ;
+M: byte-reader stream-read1 sequence-read1 ;
+M: byte-reader stream-read-until sequence-read-until ;
+M: byte-reader dispose drop ;
+
: <byte-reader> ( byte-array encoding -- stream )
- [ >byte-vector dup reverse-here ] dip <decoder> ;
+ [ B{ } like 0 byte-reader boa ] dip <decoder> ;
: with-byte-reader ( byte-array encoding quot -- )
[ <byte-reader> ] dip with-input-stream* ; inline
HELP: NOTICE
{ $description "Log level for ordinary messages." } ;
+HELP: WARNING
+{ $description "Log level for warnings." } ;
+
HELP: ERROR
{ $description "Log level for error messages." } ;
"Several log levels are supported, from lowest to highest:"
{ $subsection DEBUG }
{ $subsection NOTICE }
+{ $subsection WARNING }
{ $subsection ERROR }
{ $subsection CRITICAL } ;
HELP: log-message
{ $values { "msg" string } { "word" word } { "level" "a log level" } }
-{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
+{ $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
HELP: add-logging
{ $values { "level" "a log level" } { "word" word } }
HELP: with-logging
{ $values { "service" "a log service name" } { "quot" quotation } }
-{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ;
+{ $description "Calls the quotation a new dynamic scope where all logging calls more urgent than " { $link log-level } " are sent to the log file for " { $snippet "service" } "." } ;
ARTICLE: "logging.rotation" "Log rotation"
"Log files should be rotated periodically to prevent unbounded growth."
{ $subsection "logging.server" } ;
ABOUT: "logging"
-
words kernel arrays shuffle tools.annotations\r
prettyprint.config prettyprint debugger io.streams.string\r
splitting continuations effects generalizations parser strings\r
-quotations fry accessors ;\r
+quotations fry accessors math assocs math.order ;\r
IN: logging\r
\r
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;\r
\r
-: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;\r
+SYMBOL: log-level\r
+\r
+log-level [ DEBUG ] initialize\r
+\r
+: log-levels ( -- assoc )\r
+ H{\r
+ { DEBUG 0 }\r
+ { NOTICE 10 }\r
+ { WARNING 20 }\r
+ { ERROR 30 }\r
+ { CRITICAL 40 }\r
+ } ;\r
+\r
+ERROR: undefined-log-level ;\r
+\r
+: log-level<=> ( log-level log-level -- ? )\r
+ [ log-levels at* [ undefined-log-level ] unless ] bi@ <=> ;\r
+\r
+: log? ( log-level -- ? )\r
+ log-level get log-level<=> +lt+ = not ;\r
\r
: send-to-log-server ( array string -- )\r
prefix "log-server" get send ;\r
\r
SYMBOL: log-service\r
\r
+ERROR: bad-log-message-parameters msg word level ;\r
+\r
: check-log-message ( msg word level -- msg word level )\r
3dup [ string? ] [ word? ] [ word? ] tri* and and\r
- [ "Bad parameters to log-message" throw ] unless ; inline\r
+ [ bad-log-message-parameters ] unless ; inline\r
\r
: log-message ( msg word level -- )\r
check-log-message\r
- log-service get dup [\r
+ log-service get\r
+ 2dup [ log? ] [ ] bi* and [\r
[ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip\r
4array "log-message" send-to-log-server\r
] [\r
{ } "close-logs" send-to-log-server ;\r
\r
: with-logging ( service quot -- )\r
- log-service swap with-variable ; inline\r
+ [ log-service ] dip with-variable ; inline\r
\r
! Aspect-oriented programming idioms\r
\r
USING: accessors peg peg.parsers memoize kernel sequences\r
logging arrays words strings vectors io io.files\r
io.encodings.utf8 namespaces make combinators logging.server\r
-calendar calendar.format ;\r
+calendar calendar.format assocs ;\r
IN: logging.parser\r
\r
TUPLE: log-entry date level word-name message ;\r
"[" "]" surrounded-by ;\r
\r
: 'log-level' ( -- parser )\r
- log-levels [\r
+ log-levels keys [\r
[ name>> token ] keep [ nip ] curry action\r
] map choice ;\r
\r
dup values [ try-dispose ] each\r
clear-assoc ;\r
\r
-: keep-logs 10 ;\r
+CONSTANT: keep-logs 10\r
\r
: ?delete-file ( path -- )\r
dup exists? [ delete-file ] [ drop ] if ;\r
-! 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 ;
<PRIVATE
: real-macro-effect ( word -- effect' )
- "declared-effect" word-prop in>> 1 <effect> ;
+ stack-effect in>> 1 <effect> ;
PRIVATE>
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup math ;
+IN: math.bits
+
+ABOUT: "math.bits"
+
+ARTICLE: "math.bits" "Number bits virtual sequence"
+{ $subsection bits }
+{ $subsection <bits> }
+{ $subsection make-bits } ;
+
+HELP: bits
+{ $class-description "Virtual sequence class of bits of a number. The first bit is the least significant bit. This can be constructed with " { $link <bits> } " or " { $link make-bits } "." } ;
+
+HELP: <bits>
+{ $values { "number" integer } { "length" integer } { "bits" bits } }
+{ $description "Creates a virtual sequence of bits of a number in little endian order, with the given length." } ;
+
+HELP: make-bits
+{ $values { "number" integer } { "bits" bits } }
+{ $description "Creates a " { $link bits } " object out of the given number, using its log base 2 as the length. This implies that the last element, corresponding to the most significant bit, will be 1." }
+{ $examples
+ { $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
+ { $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
+} ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math math.bits sequences arrays ;
+IN: math.bits.tests
+
+[ t ] [ BIN: 111111 3 <bits> second ] unit-test
+[ { t t t } ] [ BIN: 111111 3 <bits> >array ] unit-test
+[ f ] [ BIN: 111101 3 <bits> second ] unit-test
+[ { f f t } ] [ BIN: 111100 3 <bits> >array ] unit-test
+[ 3 ] [ BIN: 111111 3 <bits> length ] unit-test
+[ 6 ] [ BIN: 111111 make-bits length ] unit-test
+[ 0 ] [ 0 make-bits length ] unit-test
+[ 2 ] [ 3 make-bits length ] unit-test
+[ 2 ] [ -3 make-bits length ] unit-test
+[ 1 ] [ 1 make-bits length ] unit-test
+[ 1 ] [ -1 make-bits length ] unit-test
+
+! Odd bug
+[ t ] [
+ 1067811677921310779 make-bits
+ 1067811677921310779 >bignum make-bits
+ sequence=
+] unit-test
+
+[ t ] [
+ 1067811677921310779 make-bits peek
+] unit-test
+
+[ t ] [
+ 1067811677921310779 >bignum make-bits peek
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel math accessors sequences.private ;
+IN: math.bits
+
+TUPLE: bits { number read-only } { length read-only } ;
+C: <bits> bits
+
+: make-bits ( number -- bits )
+ dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
+
+M: bits length length>> ;
+
+M: bits nth-unsafe number>> swap bit? ;
+
+INSTANCE: bits immutable-sequence
--- /dev/null
+Virtual sequence for bits of an integer
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test
-: a 1 ; inline
-: b 2 ; inline
+CONSTANT: a 1
+CONSTANT: b 2
: foo ( -- flags ) { a b } flags ;
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions sequences
+USING: arrays kernel math sequences accessors math.bits
sequences.private words namespaces macros hints
combinators fry io.binary combinators.smart ;
IN: math.bitwise
\ byte-bit-count
256 [
- 0 swap [ [ 1+ ] when ] each-bit
+ 8 <bits> 0 [ [ 1+ ] when ] reduce
] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
(( byte -- table )) define-declared
HELP: >polar
{ $values { "z" number } { "abs" "a non-negative real number" } { "arg" "a number in the interval " { $snippet "(-pi,pi]" } } }
-{ $description "Creates a complex number from an absolute value and argument (polar form)." } ;
+{ $description "Converts a complex number into an absolute value and argument (polar form)." } ;
HELP: cis
{ $values { "arg" "a real number" } { "z" "a complex number on the unit circle" } }
{ $example "USING: math prettyprint ;" "173 815 * 1119 mod ." "1" }
} ;
-HELP: each-bit
-{ $values { "n" integer } { "quot" { $quotation "( ? -- )" } } }
-{ $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." }
-{ $examples
- { $example "USING: math.functions make prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
- { $example "USING: math.functions make prettyprint ;" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" }
-} ;
-
HELP: ~
{ $values { "x" real } { "y" real } { "epsilon" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " and " { $snippet "y" } " are approximately equal to each other. There are three possible comparison tests, chosen based on the sign of " { $snippet "epsilon" } ":"
[ 6 59967 ] [ 3837888 factor-2s ] unit-test
[ 6 -59967 ] [ -3837888 factor-2s ] unit-test
+
+[ 1 ] [
+ 183009416410801897
+ 1067811677921310779
+ 2135623355842621559
+ ^mod
+] unit-test
+
+[ 1 ] [
+ 183009416410801897
+ 1067811677921310779
+ 2135623355842621559
+ [ >bignum ] tri@ ^mod
+] unit-test
\ No newline at end of file
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel math.constants math.private
+USING: math kernel math.constants math.private math.bits
math.libm combinators math.order sequences ;
IN: math.functions
M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
-: each-bit ( n quot: ( ? -- ) -- )
- over [ 0 = ] [ -1 = ] bi or [
- 2drop
- ] [
- 2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread
- ] if ; inline recursive
-
-: map-bits ( n quot: ( ? -- obj ) -- seq )
- accumulator [ each-bit ] dip ; inline
-
: factor-2s ( n -- r s )
#! factor an integer into 2^r * s
dup 0 = [ 1 ] [
GENERIC# ^n 1 ( z w -- z^w )
: (^n) ( z w -- z^w )
- 1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
+ make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
M: integer ^n
[ factor-2s ] dip [ (^n) ] keep rot * shift ;
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
: (^mod) ( n x y -- z )
- 1 swap [
+ make-bits 1 [
[ dupd * pick mod ] when [ sq over mod ] dip
- ] each-bit 2nip ; inline
+ ] reduce 2nip ; inline
: (gcd) ( b a x y -- a d )
over zero? [
[ f ] [ 36 miller-rabin ] unit-test
[ t ] [ 37 miller-rabin ] unit-test
[ 101 ] [ 100 next-prime ] unit-test
-[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
+[ t ] [ 2135623355842621559 miller-rabin ] unit-test
+[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
\ No newline at end of file
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
-! 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 ;
+prettyprint io.streams.string sequences eval namespaces ;
IN: memoize.tests
MEMO: fib ( m -- n )
[ [ \ 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
-! 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 ;
+ERROR: too-many-arguments ;
-: unpacker ( n -- quot )
- { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
+M: too-many-arguments summary
+ drop "There must be no more than 4 input and 4 output arguments" ;
-: #in ( word -- n )
- stack-effect in>> length ;
+<PRIVATE
-: #out ( word -- n )
- stack-effect out>> length ;
+: packer ( seq -- quot )
+ length { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ;
-: pack/unpack ( quot word -- newquot )
- [ dup #in unpacker % swap % #out packer % ] [ ] make ;
+: unpacker ( seq -- quot )
+ length { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
-: make-memoizer ( quot word -- quot )
- [
- [ #in packer % ] keep
- [ "memoize" word-prop , ] keep
- [ pack/unpack , ] keep
- \ cache ,
- #out unpacker %
- ] [ ] make ;
+: pack/unpack ( quot effect -- newquot )
+ [ in>> packer ] [ out>> unpacker ] bi surround ;
-ERROR: too-many-arguments ;
+: unpack/pack ( quot effect -- newquot )
+ [ in>> unpacker ] [ out>> packer ] bi surround ;
-M: too-many-arguments summary
- drop "There must be no more than 4 input and 4 output arguments" ;
+: 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 ;
-: check-memoized ( word -- )
- [ #in ] [ #out ] bi [ 4 > ] either? [ too-many-arguments ] when ;
+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
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 ;
USING: multiline kernel sequences io splitting fry namespaces
http.parsers hashtables assocs combinators ascii io.files.unique
accessors io.encodings.binary io.files byte-arrays math
-io.streams.string combinators.short-circuit strings math.order ;
+io.streams.string combinators.short-circuit strings math.order
+quoting ;
IN: mime.multipart
CONSTANT: buffer-size 65536
: empty-name? ( string -- ? )
{ "''" "\"\"" "" f } member? ;
-: quote? ( ch -- ? ) "'\"" member? ;
-
-: quoted? ( str -- ? )
- {
- [ length 1 > ]
- [ first quote? ]
- [ [ first ] [ peek ] bi = ]
- } 1&& ;
-
-: unquote ( str -- newstr )
- dup quoted? [ but-last-slice rest-slice >string ] when ;
-
: save-uploaded-file ( multipart -- )
dup filename>> empty-name? [
drop
! Just a dummy shell for the -run switch...
IN: none
-: none ;
+: none ( -- ) ;
MAIN: none
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
{ "void*" "crypto-ex-data-stack" }
{ "int" "crypto-ex-data-dummy" } ;
-: BIO_NOCLOSE HEX: 00 ; inline
-: BIO_CLOSE HEX: 01 ; inline
+CONSTANT: BIO_NOCLOSE HEX: 00
+CONSTANT: BIO_CLOSE HEX: 01
-: RSA_3 HEX: 3 ; inline
-: RSA_F4 HEX: 10001 ; inline
+CONSTANT: RSA_3 HEX: 3
+CONSTANT: RSA_F4 HEX: 10001
-: BIO_C_SET_SSL 109 ; inline
-: BIO_C_GET_SSL 110 ; inline
+CONSTANT: BIO_C_SET_SSL 109
+CONSTANT: BIO_C_GET_SSL 110
LIBRARY: libcrypto
! evp.h
! ===============================================
-: EVP_MAX_MD_SIZE 64 ;
+CONSTANT: EVP_MAX_MD_SIZE 64
C-STRUCT: EVP_MD_CTX
{ "EVP_MD*" "digest" }
TUPLE: just-parser p1 ;
-: just-pattern
+CONSTANT: just-pattern
[
execute dup [
dup remaining>> empty? [ drop f ] unless
] when
- ] ;
+ ]
M: just-parser (compile) ( parser -- quot )
M: persistent-vector length count>> ;
-: node-size 32 ; inline
+CONSTANT: node-size 32
: node-mask ( m -- n ) node-size mod ; inline
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax strings ;
+IN: quoting
+
+HELP: quote?
+{ $values
+ { "ch" "a character" }
+ { "?" "a boolean" }
+}
+{ $description "Returns true if the character is a single or double quote." } ;
+
+HELP: quoted?
+{ $values
+ { "str" string }
+ { "?" "a boolean" }
+}
+{ $description "Returns true if a string is surrounded by matching single or double quotes as the first and last characters." } ;
+
+HELP: unquote
+{ $values
+ { "str" string }
+ { "newstr" string }
+}
+{ $description "Removes a pair of matching single or double quotes from a string." } ;
+
+ARTICLE: "quoting" "Quotation marks"
+"The " { $vocab-link "quoting" } " vocabulary is for removing quotes from a string." $nl
+"Removing quotes:"
+{ $subsection unquote } ;
+
+ABOUT: "quoting"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test quoting ;
+IN: quoting.tests
+
+
+[ "abc" ] [ "'abc'" unquote ] unit-test
+[ "abc" ] [ "\"abc\"" unquote ] unit-test
+[ "'abc" ] [ "'abc" unquote ] unit-test
+[ "abc'" ] [ "abc'" unquote ] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit kernel math sequences strings ;
+IN: quoting
+
+: quote? ( ch -- ? ) "'\"" member? ;
+
+: quoted? ( str -- ? )
+ {
+ [ length 1 > ]
+ [ first quote? ]
+ [ [ first ] [ peek ] bi = ]
+ } 1&& ;
+
+: unquote ( str -- newstr )
+ dup quoted? [ but-last-slice rest-slice >string ] when ;
TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
-: n 624 ; inline
-: m 397 ; inline
-: a uint-array{ 0 HEX: 9908b0df } ; inline
+CONSTANT: n 624
+CONSTANT: m 397
+CONSTANT: a uint-array{ 0 HEX: 9908b0df }
: y ( n seq -- y )
[ nth-unsafe 31 mask-bit ]
: pop-r ( -- obj )
meta-r dup empty?
- [ too-many-r> inference-error ] [ pop ] if ;
+ [ too-many-r> ] [ pop ] if ;
: consume-r ( n -- seq )
meta-r 2dup length >
- [ too-many-r> inference-error ] when
+ [ too-many-r> ] when
[ swap tail* ] [ shorten-by ] 2bi ;
: output-r ( seq -- ) meta-r push-all ;
terminated? on meta-d clone meta-r clone #terminate, ;
: check->r ( -- )
- meta-r empty? [ \ too-many->r inference-error ] unless ;
+ meta-r empty? [ too-many->r ] unless ;
: infer-quot-here ( quot -- )
meta-r [
: infer-literal-quot ( literal -- )
dup recursive-quotation? [
- value>> recursive-quotation-error inference-error
+ value>> recursive-quotation-error
] [
dup value>> callable? [
[ value>> ]
: 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 ;
: 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 ] ?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 ;
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 )
[
} ;
ARTICLE: "inference-errors" "Inference warnings and errors"
+"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "."
+$nl
"Main wrapper for all inference warnings and errors:"
{ $subsection inference-error }
"Inference warnings:"
stack-checker.recursive-state ;
IN: stack-checker.errors
+: pretty-word ( word -- word' )
+ dup method-body? [ "method-generic" word-prop ] when ;
+
TUPLE: inference-error error type word ;
M: inference-error compiler-error-type type>> ;
: inference-warning ( ... class -- * )
+warning+ (inference-error) ; inline
-TUPLE: literal-expected ;
+TUPLE: literal-expected what ;
+
+: literal-expected ( what -- * ) \ literal-expected inference-warning ;
-M: object (literal) \ literal-expected inference-warning ;
+M: object (literal) "literal value" literal-expected ;
TUPLE: unbalanced-branches-error branches quots ;
TUPLE: too-many->r ;
+: too-many->r ( -- * ) \ too-many->r inference-error ;
+
TUPLE: too-many-r> ;
+: too-many-r> ( -- * ) \ too-many-r> inference-error ;
+
TUPLE: missing-effect word ;
+: missing-effect ( word -- * )
+ pretty-word \ missing-effect inference-error ;
+
TUPLE: effect-error word inferred declared ;
: effect-error ( word inferred declared -- * )
TUPLE: recursive-quotation-error quot ;
+: recursive-quotation-error ( word -- * )
+ \ recursive-quotation-error inference-error ;
+
TUPLE: undeclared-recursion-error word ;
+: undeclared-recursion-error ( word -- * )
+ \ undeclared-recursion-error inference-error ;
+
TUPLE: diverging-recursion-error word ;
+: diverging-recursion-error ( word -- * )
+ \ diverging-recursion-error inference-error ;
+
TUPLE: unbalanced-recursion-error word height ;
+: unbalanced-recursion-error ( word height -- * )
+ \ unbalanced-recursion-error inference-error ;
+
TUPLE: inconsistent-recursive-call-error word ;
+: inconsistent-recursive-call-error ( word -- * )
+ \ inconsistent-recursive-call-error inference-error ;
+
TUPLE: unknown-primitive-error ;
+
+: unknown-primitive-error ( -- * )
+ \ unknown-primitive-error inference-warning ;
M: inference-error error.
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
-M: literal-expected summary
- drop "Literal value expected" ;
+M: literal-expected error.
+ "Got a computed value where a " write what>> write " was expected" print ;
M: unbalanced-branches-error error.
"Unbalanced branches:" print
terminated? get [ 1 infer-r> infer-call ] unless ;
M: object infer-call*
- \ literal-expected inference-warning ;
+ "literal quotation" literal-expected ;
: infer-nslip ( n -- )
[ infer->r infer-call ] [ infer-r> ] bi ;
apply-word/effect ;
: infer-exit ( -- )
- \ exit
- { integer } { } t >>terminated? <effect>
- apply-word/effect ;
+ \ exit (( n -- * )) apply-word/effect ;
: infer-load-locals ( -- )
pop-literal nip
{ \ load-locals [ infer-load-locals ] }
{ \ get-local [ infer-get-local ] }
{ \ drop-locals [ infer-drop-locals ] }
- { \ do-primitive [ unknown-primitive-error inference-warning ] }
+ { \ do-primitive [ unknown-primitive-error ] }
{ \ alien-invoke [ infer-alien-invoke ] }
{ \ alien-indirect [ infer-alien-indirect ] }
{ \ alien-callback [ infer-alien-callback ] }
{
declare call (call) slip 2slip 3slip dip 2dip 3dip
curry compose execute (execute) if dispatch <tuple-boa>
- (throw) load-local load-locals get-local drop-locals do-primitive
+ (throw) exit load-local load-locals get-local drop-locals do-primitive
alien-invoke alien-indirect alien-callback
} [ t "special" set-word-prop ] each
\ 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
ARTICLE: "inference-combinators" "Combinator stack effects"
"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
-{ $example "[ dup call ] infer." "Literal value expected\n\nType :help for debugging help." }
+{ $example "[ dup call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:"
{ $example "[ [ 2 + ] call ] infer." "( object -- object )" }
"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
{ $example ": foo 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" }
"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:"
{ $example
- "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Literal value expected\n\nType :help for debugging help."
+ "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help."
}
"To make this work, pass the quotation on the retain stack instead:"
{ $example
"When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect."
$nl
"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":"
-{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if" "[ foo ] infer." }
+{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." }
"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ;
ARTICLE: "inference-recursive-combinators" "Recursive combinator inference"
"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "."
$nl
"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:"
-{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Literal value expected\n\nType :help for debugging help." }
+{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"The following is correct:"
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
-{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Literal value expected\n\nType :help for debugging help." }
+{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"However a small change can be made:"
{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" }
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"
sorting assocs definitions prettyprint io inspector
classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread
-sequences.private destructors combinators eval locals.backend ;
+sequences.private destructors combinators eval locals.backend
+system ;
IN: stack-checker.tests
\ infer. must-infer
: debugging-curry-folding ( quot -- )
[ debugging-curry-folding ] curry call ; inline recursive
-[ [ ] debugging-curry-folding ] must-infer
\ No newline at end of file
+[ [ ] debugging-curry-folding ] must-infer
+
+[ [ exit ] [ 1 2 3 ] if ] must-infer
\ No newline at end of file
] 1 define-transform
! Membership testing
-: bit-member-n 256 ; inline
+CONSTANT: bit-member-n 256
: bit-member? ( seq -- ? )
#! Can we use a fast byte array test here?
while
drop ;
-: start ( namestack thread -- )
+: start ( namestack thread -- * )
[
set-self
set-namestack
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 = ;
SYMBOL: deploy-reflection
-: deploy-reflection-options
+CONSTANT: deploy-reflection-options
{
{ 1 "Level 1 - No reflection" }
{ 2 "Level 2 - Retain word names" }
{ 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 < ;
"cannot-infer"
"coercer"
"combination"
- "compiled-effect"
+ "compiled-status"
"compiled-generic-uses"
"compiled-uses"
"constraints"
"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
: UD_SYN_INTEL ( -- addr ) &: ud_translate_intel ; inline
: UD_SYN_ATT ( -- addr ) &: ud_translate_att ; inline
-: UD_EOI -1 ; inline
-: UD_INP_CACHE_SZ 32 ; inline
-: UD_VENDOR_AMD 0 ; inline
-: UD_VENDOR_INTEL 1 ; inline
+CONSTANT: UD_EOI -1
+CONSTANT: UD_INP_CACHE_SZ 32
+CONSTANT: UD_VENDOR_AMD 0
+CONSTANT: UD_VENDOR_INTEL 1
FUNCTION: void ud_init ( ud* u ) ;
FUNCTION: void ud_set_mode ( ud* u, uint8_t mode ) ;
PRIVATE>
-SYMBOLS: file-name file-name/type permissions file-type nlinks file-size
-file-date file-time file-datetime uid gid user group link-target unix-datetime
-directory-or-size ;
+SYMBOLS: +file-name+ +file-name/type+ +permissions+ +file-type+
++nlinks+ +file-size+ +file-date+ +file-time+ +file-datetime+
++uid+ +gid+ +user+ +group+ +link-target+ +unix-datetime+
++directory-or-size+ ;
TUPLE: listing-tool path specs sort ;
: <listing-tool> ( path -- listing-tool )
listing-tool new
swap >>path
- { file-name } >>specs ;
+ { +file-name+ } >>specs ;
: list-slow? ( listing-tool -- ? )
- specs>> { file-name } sequence= not ;
+ specs>> { +file-name+ } sequence= not ;
ERROR: unknown-file-spec symbol ;
M: object file-spec>string ( file-listing spec -- string )
{
- { file-name [ directory-entry>> name>> ] }
- { directory-or-size [ file-info>> dir-or-size ] }
- { file-size [ file-info>> size>> number>string ] }
- { file-date [ file-info>> modified>> listing-date ] }
- { file-time [ file-info>> modified>> listing-time ] }
- { file-datetime [ file-info>> modified>> timestamp>ymdhms ] }
+ { +file-name+ [ directory-entry>> name>> ] }
+ { +directory-or-size+ [ file-info>> dir-or-size ] }
+ { +file-size+ [ file-info>> size>> number>string ] }
+ { +file-date+ [ file-info>> modified>> listing-date ] }
+ { +file-time+ [ file-info>> modified>> listing-time ] }
+ { +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] }
[ unknown-file-spec ]
} case ;
: directory. ( path -- ) (directory.) simple-table. ;
-SYMBOLS: device-name mount-point type
-available-space free-space used-space total-space
-percent-used percent-free ;
+SYMBOLS: +device-name+ +mount-point+ +type+
++available-space+ +free-space+ +used-space+ +total-space+
++percent-used+ +percent-free+ ;
: percent ( real -- integer ) 100 * >integer ; inline
: file-system-spec ( file-system-info obj -- str )
{
- { device-name [ device-name>> "" or ] }
- { mount-point [ mount-point>> "" or ] }
- { type [ type>> "" or ] }
- { available-space [ available-space>> 0 or ] }
- { free-space [ free-space>> 0 or ] }
- { used-space [ used-space>> 0 or ] }
- { total-space [ total-space>> 0 or ] }
- { percent-used [
+ { +device-name+ [ device-name>> "" or ] }
+ { +mount-point+ [ mount-point>> "" or ] }
+ { +type+ [ type>> "" or ] }
+ { +available-space+ [ available-space>> 0 or ] }
+ { +free-space+ [ free-space>> 0 or ] }
+ { +used-space+ [ used-space>> 0 or ] }
+ { +total-space+ [ total-space>> 0 or ] }
+ { +percent-used+ [
[ used-space>> ] [ total-space>> ] bi
[ 0 or ] bi@ dup 0 =
[ 2drop 0 ] [ / percent ] if
: file-systems. ( -- )
{
- device-name available-space free-space used-space
- total-space percent-used mount-point
+ +device-name+ +available-space+ +free-space+ +used-space+
+ +total-space+ +percent-used+ +mount-point+
} print-file-systems ;
{
M: unix (directory.) ( path -- lines )
<listing-tool>
- { permissions nlinks user group file-size file-date file-name } >>specs
+ {
+ +permissions+ +nlinks+ +user+ +group+
+ +file-size+ +file-date+ +file-name+
+ } >>specs
{ { directory-entry>> name>> <=> } } >>sort
[ [ list-files ] with-group-cache ] with-user-cache ;
M: unix file-spec>string ( file-listing spec -- string )
{
- { file-name/type [
+ { +file-name/type+ [
directory-entry>> [ name>> ] [ file-type>trailing ] bi append
] }
- { permissions [ file-info>> permissions-string ] }
- { nlinks [ file-info>> nlink>> number>string ] }
- { user [ file-info>> uid>> user-name ] }
- { group [ file-info>> gid>> group-name ] }
- { uid [ file-info>> uid>> number>string ] }
- { gid [ file-info>> gid>> number>string ] }
+ { +permissions+ [ file-info>> permissions-string ] }
+ { +nlinks+ [ file-info>> nlink>> number>string ] }
+ { +user+ [ file-info>> uid>> user-name ] }
+ { +group+ [ file-info>> gid>> group-name ] }
+ { +uid+ [ file-info>> uid>> number>string ] }
+ { +gid+ [ file-info>> gid>> number>string ] }
[ call-next-method ]
} case ;
M: windows (directory.) ( entries -- lines )
<listing-tool>
- { file-datetime directory-or-size file-name } >>specs
+ { +file-datetime+ +directory-or-size+ +file-name+ } >>specs
{ { directory-entry>> name>> <=> } } >>sort
list-files ;
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 compiler.units
words ;
[ t ] [
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings words ;
+USING: help.markup help.syntax kernel strings words vocabs ;
IN: tools.scaffold
HELP: developer-name
{ $description "Prints out scaffold help markup for a given word." } ;
HELP: scaffold-help
-{ $values { "string" string } }
+{ $values { "vocab" vocab } }
{ $description "Takes an existing vocabulary and creates a help file with scaffolded help for each word. This word only works if no help file yet exists." } ;
HELP: scaffold-undocumented
{ "vocab-root" "a vocabulary root string" } { "string" string } }
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
+HELP: scaffold-emacs
+{ $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;
+
+HELP: scaffold-factor-boot-rc
+{ $description "Touches the .factor-boot-rc file in your home directory and provides a clickable link to open it in an editor." } ;
+
+HELP: scaffold-factor-rc
+{ $description "Touches the .factor-rc file in your home directory and provides a clickable link to open it in an editor." } ;
+
+HELP: scaffold-rc
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "Touches the given path in your home directory and provides a clickable link to open it in an editor." } ;
+
HELP: using
{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
{ $subsection scaffold-help }
{ $subsection scaffold-undocumented }
{ $subsection help. }
-"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead."
+"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead." $nl
+"Scaffolding a configuration file:"
+{ $subsection scaffold-rc }
+{ $subsection scaffold-factor-boot-rc }
+{ $subsection scaffold-factor-rc }
+{ $subsection scaffold-emacs }
;
ABOUT: "tools.scaffold"
vocabs.loader io combinators calendar accessors math.parser
io.streams.string ui.tools.operations quotations strings arrays
prettyprint words vocabs sorting sets classes math alien urls
-splitting ascii ;
+splitting ascii combinators.short-circuit ;
IN: tools.scaffold
SYMBOL: developer-name
<PRIVATE
-: root? ( string -- ? ) vocab-roots get member? ;
+: vocab-root? ( string -- ? ) vocab-roots get member? ;
: contains-dot? ( string -- ? ) ".." swap subseq? ;
: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
: check-vocab-name ( string -- string )
- dup contains-dot? [ vocab-name-contains-dot ] when
- dup contains-separator? [ vocab-name-contains-separator ] when ;
+ [ ]
+ [ contains-dot? [ vocab-name-contains-dot ] when ]
+ [ contains-separator? [ vocab-name-contains-separator ] when ] tri ;
: check-root ( string -- string )
- dup root? [ not-a-vocab-root ] unless ;
+ dup vocab-root? [ not-a-vocab-root ] unless ;
+
+: check-vocab ( vocab -- vocab )
+ dup find-vocab-root [ no-vocab ] unless ;
+
+: check-vocab-root/vocab ( vocab-root string -- vocab-root string )
+ [ check-root ] [ check-vocab-name ] bi* ;
+
+: replace-vocab-separators ( vocab -- path )
+ path-separator first CHAR: . associate substitute ; inline
+
+: vocab-root/vocab>path ( vocab-root vocab -- path )
+ check-vocab-root/vocab
+ [ ] [ replace-vocab-separators ] bi* append-path ;
+
+: vocab>path ( vocab -- path )
+ check-vocab
+ [ find-vocab-root ] keep vocab-root/vocab>path ;
+
+: vocab-root/vocab/file>path ( vocab-root vocab file -- path )
+ [ vocab-root/vocab>path ] dip append-path ;
+
+: vocab-root/vocab/suffix>path ( vocab-root vocab suffix -- path )
+ [ vocab-root/vocab>path dup file-name append-path ] dip append ;
+
+: vocab/suffix>path ( vocab suffix -- path )
+ [ vocab>path dup file-name append-path ] dip append ;
: directory-exists ( path -- )
"Not creating a directory, it already exists: " write print ;
-: scaffold-directory ( path -- )
+: scaffold-directory ( vocab-root vocab -- )
+ vocab-root/vocab>path
dup exists? [ directory-exists ] [ make-directories ] if ;
-: not-scaffolding ( path -- )
- "Not creating scaffolding for " write <pathname> . ;
-
-: scaffolding ( path -- )
- "Creating scaffolding for " write <pathname> . ;
+: not-scaffolding ( path -- path )
+ "Not creating scaffolding for " write dup <pathname> . ;
-: (scaffold-path) ( path string -- path )
- dupd [ file-name ] dip append append-path ;
+: scaffolding ( path -- path )
+ "Creating scaffolding for " write dup <pathname> . ;
-: scaffold-path ( path string -- path ? )
- (scaffold-path)
- dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
+: scaffolding? ( path -- path ? )
+ dup exists? [ not-scaffolding f ] [ scaffolding t ] if ;
: scaffold-copyright ( -- )
"! Copyright (C) " write now year>> number>string write
"IN: " write print
] with-string-writer ;
-: set-scaffold-main-file ( path vocab -- )
- main-file-string swap utf8 set-file-contents ;
-
-: scaffold-main ( path vocab -- )
- [ ".factor" scaffold-path ] dip
- swap [ set-scaffold-main-file ] [ 2drop ] if ;
-
-: tests-file-string ( vocab -- string )
- [
- scaffold-copyright
- "USING: tools.test " write dup write " ;" print
- "IN: " write write ".tests" print
- ] with-string-writer ;
-
-: set-scaffold-tests-file ( path vocab -- )
- tests-file-string swap utf8 set-file-contents ;
+: set-scaffold-main-file ( vocab path -- )
+ [ main-file-string ] dip utf8 set-file-contents ;
-: scaffold-tests ( path vocab -- )
- [ "-tests.factor" scaffold-path ] dip
- swap [ set-scaffold-tests-file ] [ 2drop ] if ;
+: scaffold-main ( vocab-root vocab -- )
+ tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [
+ set-scaffold-main-file
+ ] [
+ 2drop
+ ] if ;
-: scaffold-authors ( path -- )
- "authors.txt" append-path dup exists? [
- not-scaffolding
+: scaffold-authors ( vocab-root vocab -- )
+ "authors.txt" vocab-root/vocab/file>path scaffolding? [
+ [ developer-name get ] dip utf8 set-file-contents
] [
- dup scaffolding
- developer-name get swap utf8 set-file-contents
+ drop
] if ;
: lookup-type ( string -- object/string ? )
- "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-tail
+ "new" ?head drop [ { [ CHAR: ' = ] [ digit? ] } 1|| ] trim-tail
H{
{ "object" object } { "obj" object }
{ "quot" quotation }
" }" write
] each ;
+: 4bl ( -- )
+ " " write ; inline
+
: $values. ( word -- )
"declared-effect" word-prop [
[ in>> ] [ out>> ] bi
2drop
] [
"{ $values" print
- [ " " write ($values.) ]
- [ [ nl " " write ($values.) ] unless-empty ] bi*
+ [ 4bl ($values.) ]
+ [ [ nl 4bl ($values.) ] unless-empty ] bi*
nl "}" print
] if
] when* ;
drop
"{ $description \"\" } ;" print ;
-: help-header. ( word -- )
+: docs-header. ( word -- )
"HELP: " write name>> print ;
: (help.) ( word -- )
- [ help-header. ] [ $values. ] [ $description. ] tri ;
+ [ docs-header. ] [ $values. ] [ $description. ] tri ;
: interesting-words ( vocab -- array )
words
- [ [ "help" word-prop ] [ predicate? ] bi or not ] filter
+ [ { [ "help" word-prop ] [ predicate? ] } 1|| not ] filter
natural-sort ;
: interesting-words. ( vocab -- )
interesting-words [ (help.) nl ] each ;
-: help-file-string ( vocab -- str2 )
+: docs-file-string ( vocab -- str2 )
[
{
[ "IN: " write print nl ]
[ bl write ] each
" ;" print ;
-: set-scaffold-help-file ( path vocab -- )
- swap utf8 <file-writer> [
+: set-scaffold-docs-file ( vocab path -- )
+ utf8 <file-writer> [
scaffold-copyright
- [ help-file-string ] [ write-using ] bi
+ [ docs-file-string ] [ write-using ] bi
write
] with-output-stream ;
-: check-scaffold ( vocab-root string -- vocab-root string )
- [ check-root ] [ check-vocab-name ] bi* ;
-
-: vocab>scaffold-path ( vocab-root string -- path )
- path-separator first CHAR: . associate substitute
- append-path ;
-
-: prepare-scaffold ( vocab-root string -- string path )
- check-scaffold [ vocab>scaffold-path ] keep ;
-
: with-scaffold ( quot -- )
[ H{ } clone using ] dip with-variable ; inline
-: check-vocab ( vocab -- vocab )
- dup find-vocab-root [ no-vocab ] unless ;
-
-PRIVATE>
-
: link-vocab ( vocab -- )
check-vocab
"Edit documentation: " write
- [ find-vocab-root ]
- [ vocab>scaffold-path ] bi
- "-docs.factor" (scaffold-path) <pathname> . ;
+ "-docs.factor" vocab/suffix>path <pathname> . ;
+
+PRIVATE>
: help. ( word -- )
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
-: scaffold-help ( string -- )
+: scaffold-help ( vocab -- )
[
- [ find-vocab-root ] [ check-vocab ] bi
- prepare-scaffold
- [ "-docs.factor" scaffold-path ] dip
- swap [ set-scaffold-help-file ] [ 2drop ] if
+ dup "-docs.factor" vocab/suffix>path scaffolding? [
+ set-scaffold-docs-file
+ ] [
+ 2drop
+ ] if
] with-scaffold ;
: scaffold-undocumented ( string -- )
[ interesting-words. ] [ link-vocab ] bi ;
: scaffold-vocab ( vocab-root string -- )
- prepare-scaffold
{
- [ drop scaffold-directory ]
+ [ scaffold-directory ]
[ scaffold-main ]
- [ scaffold-tests ]
- [ drop scaffold-authors ]
+ [ scaffold-authors ]
[ nip require ]
} 2cleave ;
+<PRIVATE
+
+: tests-file-string ( vocab -- string )
+ [
+ scaffold-copyright
+ "USING: tools.test " write dup write " ;" print
+ "IN: " write write ".tests" print
+ ] with-string-writer ;
+
+: set-scaffold-tests-file ( vocab path -- )
+ [ tests-file-string ] dip utf8 set-file-contents ;
+
+PRIVATE>
+
+: scaffold-tests ( vocab -- )
+ dup "-tests.factor" vocab/suffix>path
+ scaffolding? [
+ set-scaffold-tests-file
+ ] [
+ 2drop
+ ] if ;
+
SYMBOL: examples-flag
: example ( -- )
" \"\""
" \"\""
"}"
- } [ examples-flag get [ " " write ] when print ] each ;
+ } [ examples-flag get [ 4bl ] when print ] each ;
: examples ( n -- )
t \ examples-flag [
] with-variable ;
: scaffold-rc ( path -- )
+ [ home ] dip append-path
[ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
-: scaffold-factor-boot-rc ( -- )
- home ".factor-boot-rc" append-path scaffold-rc ;
+: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ;
+
+: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ;
-: scaffold-factor-rc ( -- )
- home ".factor-rc" append-path scaffold-rc ;
+: scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
#! 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" }
{ 126 "UP" }
{ 116 "PAGE_UP" }
{ 121 "PAGE_DOWN" }
- } ;
+ }
: key-code ( event -- string ? )
dup -> keyCode key-codes at
<PRIVATE
-: circle-steps 8 ;
+CONSTANT: circle-steps 8
PRIVATE>
-USING: help.syntax help.markup ui.gadgets kernel arrays
+USING: help.syntax help.markup ui.gadgets kernel arrays math help sequences
quotations classes.tuple ui.gadgets.grids ;
IN: ui.gadgets.frames
drop
{ $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
-HELP: @center $ui-frame-constant ;
-HELP: @left $ui-frame-constant ;
-HELP: @right $ui-frame-constant ;
-HELP: @top $ui-frame-constant ;
-HELP: @bottom $ui-frame-constant ;
-HELP: @top-left $ui-frame-constant ;
-HELP: @top-right $ui-frame-constant ;
-HELP: @bottom-left $ui-frame-constant ;
-HELP: @bottom-right $ui-frame-constant ;
+{ @center @left @right @top @bottom @top-left @top-right @bottom-left @bottom-right }
+[
+ [
+ {
+ { $values { "i" integer } { "j" integer } }
+ { $ui-frame-constant }
+ }
+ ] dip set-word-help
+] each
HELP: frame
{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
: <frame-grid> ( -- grid ) 9 [ <glue> ] replicate 3 group ;
-: @center 1 1 ; inline
-: @left 0 1 ; inline
-: @right 2 1 ; inline
-: @top 1 0 ; inline
-: @bottom 1 2 ; inline
-
-: @top-left 0 0 ; inline
-: @top-right 2 0 ; inline
-: @bottom-left 0 2 ; inline
-: @bottom-right 2 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 ( -- 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 ;
: 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 ;
T{ gray f 0.5 1.0 }
} <gradient> ;
-: 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 }
[ [ 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 } }
: <polygon-gadget> ( color points -- gadget )
dup max-dim
[ lo-word ] keep hi-word 2array
swap window (>>window-loc) ;
-: wm-keydown-codes ( -- key )
+CONSTANT: wm-keydown-codes
H{
{ 8 "BACKSPACE" }
{ 9 "TAB" }
{ 121 "F10" }
{ 122 "F11" }
{ 123 "F12" }
- } ;
+ }
: key-state-down? ( key -- ? )
GetKeyState 16 bit? ;
alt? [ A+ , ] when
] { } make [ empty? not ] keep f ? ;
-: exclude-keys-wm-keydown
+CONSTANT: exclude-keys-wm-keydown
H{
{ 16 "SHIFT" }
{ 17 "CTRL" }
{ 18 "ALT" }
{ 20 "CAPS-LOCK" }
- } ;
+ }
-: exclude-keys-wm-char
- ! Values are ignored
+! Values are ignored
+CONSTANT: exclude-keys-wm-char
H{
{ 8 "BACKSPACE" }
{ 9 "TAB" }
{ 13 "RET" }
{ 27 "ESC" }
- } ;
+ }
: exclude-key-wm-keydown? ( n -- ? )
exclude-keys-wm-keydown key? ;
ui.event-loop assocs kernel math namespaces opengl sequences
strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
x11.constants x11.windows io.encodings.string io.encodings.ascii
-io.encodings.utf8 combinators command-line
+io.encodings.utf8 combinators combinators.short-circuit command-line
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ascii ;
IN: ui.x11
! In case dimensions didn't change
relayout-1 ;
-: modifiers
+CONSTANT: modifiers
{
{ S+ HEX: 1 }
{ C+ HEX: 4 }
{ A+ HEX: 8 }
- } ;
-
-: key-codes
+ }
+
+CONSTANT: key-codes
H{
{ HEX: FF08 "BACKSPACE" }
{ HEX: FF09 "TAB" }
{ HEX: FFC4 "F7" }
{ HEX: FFC5 "F8" }
{ HEX: FFC6 "F9" }
- } ;
+ }
: key-code ( keysym -- keycode action? )
dup key-codes at [ t ] [ 1string f ] ?if ;
: valid-input? ( string gesture -- ? )
over empty? [ 2drop f ] [
mods>> { f { S+ } } member? [
- [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
+ [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
] [
- [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
+ [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
] if
] if ;
[ 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"
"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
: group-name ( id -- string )
dup group-cache get [
- dupd at* [ name>> nip ] [ drop number>string ] if
+ ?at [ name>> ] [ number>string ] if
] [
group-struct [ group-gr_name ] [ f ] if*
] if*
{ 64 [ "unix.stat.netbsd.64" require ] }
} case
-: _VFS_NAMELEN 32 ; inline
-: _VFS_MNAMELEN 1024 ; inline
+CONSTANT: _VFS_NAMELEN 32
+CONSTANT: _VFS_MNAMELEN 1024
C-STRUCT: statvfs
{ "ulong" "f_flag" }
deques search-deques hashtables ;
IN: unrolled-lists
-: unroll-factor 32 ; inline
+CONSTANT: unroll-factor 32
<PRIVATE
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
FUNCTION: DWORD GetFileAttributesW ( LPCTSTR lpFileName ) ;
! FUNCTION: GetFileAttributesExA
-: GetFileExInfoStandard 0 ; inline
+CONSTANT: GetFileExInfoStandard 0
FUNCTION: BOOL GetFileAttributesExW ( LPCTSTR lpFileName, GET_FILEEX_INFO_LEVELS fInfoLevelId, LPVOID lpFileInformation ) ;
FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
-: S_OK 0 ; inline
-: S_FALSE 1 ; inline
-: E_NOINTERFACE HEX: 80004002 ; inline
-: E_FAIL HEX: 80004005 ; inline
-: E_INVALIDARG HEX: 80070057 ; inline
-
-: MK_ALT HEX: 20 ; inline
-: DROPEFFECT_NONE 0 ; inline
-: DROPEFFECT_COPY 1 ; inline
-: DROPEFFECT_MOVE 2 ; inline
-: DROPEFFECT_LINK 4 ; inline
-: DROPEFFECT_SCROLL HEX: 80000000 ; inline
-: DD_DEFSCROLLINSET 11 ; inline
-: DD_DEFSCROLLDELAY 50 ; inline
-: DD_DEFSCROLLINTERVAL 50 ; inline
-: DD_DEFDRAGDELAY 200 ; inline
-: DD_DEFDRAGMINDIST 2 ; inline
-
-: CF_TEXT 1 ; inline
-: CF_BITMAP 2 ; inline
-: CF_METAFILEPICT 3 ; inline
-: CF_SYLK 4 ; inline
-: CF_DIF 5 ; inline
-: CF_TIFF 6 ; inline
-: CF_OEMTEXT 7 ; inline
-: CF_DIB 8 ; inline
-: CF_PALETTE 9 ; inline
-: CF_PENDATA 10 ; inline
-: CF_RIFF 11 ; inline
-: CF_WAVE 12 ; inline
-: CF_UNICODETEXT 13 ; inline
-: CF_ENHMETAFILE 14 ; inline
-: CF_HDROP 15 ; inline
-: CF_LOCALE 16 ; inline
-: CF_MAX 17 ; inline
-
-: CF_OWNERDISPLAY HEX: 0080 ; inline
-: CF_DSPTEXT HEX: 0081 ; inline
-: CF_DSPBITMAP HEX: 0082 ; inline
-: CF_DSPMETAFILEPICT HEX: 0083 ; inline
-: CF_DSPENHMETAFILE HEX: 008E ; inline
-
-: DVASPECT_CONTENT 1 ; inline
-: DVASPECT_THUMBNAIL 2 ; inline
-: DVASPECT_ICON 4 ; inline
-: DVASPECT_DOCPRINT 8 ; inline
-
-: TYMED_HGLOBAL 1 ; inline
-: TYMED_FILE 2 ; inline
-: TYMED_ISTREAM 4 ; inline
-: TYMED_ISTORAGE 8 ; inline
-: TYMED_GDI 16 ; inline
-: TYMED_MFPICT 32 ; inline
-: TYMED_ENHMF 64 ; inline
-: TYMED_NULL 0 ; inline
+CONSTANT: S_OK 0
+CONSTANT: S_FALSE 1
+CONSTANT: E_NOINTERFACE HEX: 80004002
+CONSTANT: E_FAIL HEX: 80004005
+CONSTANT: E_INVALIDARG HEX: 80070057
+
+CONSTANT: MK_ALT HEX: 20
+CONSTANT: DROPEFFECT_NONE 0
+CONSTANT: DROPEFFECT_COPY 1
+CONSTANT: DROPEFFECT_MOVE 2
+CONSTANT: DROPEFFECT_LINK 4
+CONSTANT: DROPEFFECT_SCROLL HEX: 80000000
+CONSTANT: DD_DEFSCROLLINSET 11
+CONSTANT: DD_DEFSCROLLDELAY 50
+CONSTANT: DD_DEFSCROLLINTERVAL 50
+CONSTANT: DD_DEFDRAGDELAY 200
+CONSTANT: DD_DEFDRAGMINDIST 2
+
+CONSTANT: CF_TEXT 1
+CONSTANT: CF_BITMAP 2
+CONSTANT: CF_METAFILEPICT 3
+CONSTANT: CF_SYLK 4
+CONSTANT: CF_DIF 5
+CONSTANT: CF_TIFF 6
+CONSTANT: CF_OEMTEXT 7
+CONSTANT: CF_DIB 8
+CONSTANT: CF_PALETTE 9
+CONSTANT: CF_PENDATA 10
+CONSTANT: CF_RIFF 11
+CONSTANT: CF_WAVE 12
+CONSTANT: CF_UNICODETEXT 13
+CONSTANT: CF_ENHMETAFILE 14
+CONSTANT: CF_HDROP 15
+CONSTANT: CF_LOCALE 16
+CONSTANT: CF_MAX 17
+
+CONSTANT: CF_OWNERDISPLAY HEX: 0080
+CONSTANT: CF_DSPTEXT HEX: 0081
+CONSTANT: CF_DSPBITMAP HEX: 0082
+CONSTANT: CF_DSPMETAFILEPICT HEX: 0083
+CONSTANT: CF_DSPENHMETAFILE HEX: 008E
+
+CONSTANT: DVASPECT_CONTENT 1
+CONSTANT: DVASPECT_THUMBNAIL 2
+CONSTANT: DVASPECT_ICON 4
+CONSTANT: DVASPECT_DOCPRINT 8
+
+CONSTANT: TYMED_HGLOBAL 1
+CONSTANT: TYMED_FILE 2
+CONSTANT: TYMED_ISTREAM 4
+CONSTANT: TYMED_ISTORAGE 8
+CONSTANT: TYMED_GDI 16
+CONSTANT: TYMED_MFPICT 32
+CONSTANT: TYMED_ENHMF 64
+CONSTANT: TYMED_NULL 0
C-STRUCT: DVTARGETDEVICE
{ "DWORD" "tdSize" }
{ "LPUNKNOWN" "punkForRelease" } ;
TYPEDEF: STGMEDIUM* LPSTGMEDIUM
-: COINIT_MULTITHREADED 0 ; inline
-: COINIT_APARTMENTTHREADED 2 ; inline
-: COINIT_DISABLE_OLE1DDE 4 ; inline
-: COINIT_SPEED_OVER_MEMORY 8 ; inline
+CONSTANT: COINIT_MULTITHREADED 0
+CONSTANT: COINIT_APARTMENTTHREADED 2
+CONSTANT: COINIT_DISABLE_OLE1DDE 4
+CONSTANT: COINIT_SPEED_OVER_MEMORY 8
FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
IN: windows.opengl32
! PIXELFORMATDESCRIPTOR flags
-: PFD_DOUBLEBUFFER HEX: 00000001 ; inline
-: PFD_STEREO HEX: 00000002 ; inline
-: PFD_DRAW_TO_WINDOW HEX: 00000004 ; inline
-: PFD_DRAW_TO_BITMAP HEX: 00000008 ; inline
-: PFD_SUPPORT_GDI HEX: 00000010 ; inline
-: PFD_SUPPORT_OPENGL HEX: 00000020 ; inline
-: PFD_GENERIC_FORMAT HEX: 00000040 ; inline
-: PFD_NEED_PALETTE HEX: 00000080 ; inline
-: PFD_NEED_SYSTEM_PALETTE HEX: 00000100 ; inline
-: PFD_SWAP_EXCHANGE HEX: 00000200 ; inline
-: PFD_SWAP_COPY HEX: 00000400 ; inline
-: PFD_SWAP_LAYER_BUFFERS HEX: 00000800 ; inline
-: PFD_GENERIC_ACCELERATED HEX: 00001000 ; inline
-: PFD_SUPPORT_DIRECTDRAW HEX: 00002000 ; inline
+CONSTANT: PFD_DOUBLEBUFFER HEX: 00000001
+CONSTANT: PFD_STEREO HEX: 00000002
+CONSTANT: PFD_DRAW_TO_WINDOW HEX: 00000004
+CONSTANT: PFD_DRAW_TO_BITMAP HEX: 00000008
+CONSTANT: PFD_SUPPORT_GDI HEX: 00000010
+CONSTANT: PFD_SUPPORT_OPENGL HEX: 00000020
+CONSTANT: PFD_GENERIC_FORMAT HEX: 00000040
+CONSTANT: PFD_NEED_PALETTE HEX: 00000080
+CONSTANT: PFD_NEED_SYSTEM_PALETTE HEX: 00000100
+CONSTANT: PFD_SWAP_EXCHANGE HEX: 00000200
+CONSTANT: PFD_SWAP_COPY HEX: 00000400
+CONSTANT: PFD_SWAP_LAYER_BUFFERS HEX: 00000800
+CONSTANT: PFD_GENERIC_ACCELERATED HEX: 00001000
+CONSTANT: PFD_SUPPORT_DIRECTDRAW HEX: 00002000
! PIXELFORMATDESCRIPTOR flags for use in ChoosePixelFormat only
-: PFD_DEPTH_DONTCARE HEX: 20000000 ; inline
-: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000 ; inline
-: PFD_STEREO_DONTCARE HEX: 80000000 ; inline
+CONSTANT: PFD_DEPTH_DONTCARE HEX: 20000000
+CONSTANT: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000
+CONSTANT: PFD_STEREO_DONTCARE HEX: 80000000
! pixel types
-: PFD_TYPE_RGBA 0 ; inline
-: PFD_TYPE_COLORINDEX 1 ; inline
+CONSTANT: PFD_TYPE_RGBA 0
+CONSTANT: PFD_TYPE_COLORINDEX 1
! layer types
-: PFD_MAIN_PLANE 0 ; inline
-: PFD_OVERLAY_PLANE 1 ; inline
-: PFD_UNDERLAY_PLANE -1 ; inline
+CONSTANT: PFD_MAIN_PLANE 0
+CONSTANT: PFD_OVERLAY_PLANE 1
+CONSTANT: PFD_UNDERLAY_PLANE -1
-: LPD_TYPE_RGBA 0 ; inline
-: LPD_TYPE_COLORINDEX 1 ; inline
+CONSTANT: LPD_TYPE_RGBA 0
+CONSTANT: LPD_TYPE_COLORINDEX 1
! wglSwapLayerBuffers flags
-: WGL_SWAP_MAIN_PLANE HEX: 00000001 ; inline
-: WGL_SWAP_OVERLAY1 HEX: 00000002 ; inline
-: WGL_SWAP_OVERLAY2 HEX: 00000004 ; inline
-: WGL_SWAP_OVERLAY3 HEX: 00000008 ; inline
-: WGL_SWAP_OVERLAY4 HEX: 00000010 ; inline
-: WGL_SWAP_OVERLAY5 HEX: 00000020 ; inline
-: WGL_SWAP_OVERLAY6 HEX: 00000040 ; inline
-: WGL_SWAP_OVERLAY7 HEX: 00000080 ; inline
-: WGL_SWAP_OVERLAY8 HEX: 00000100 ; inline
-: WGL_SWAP_OVERLAY9 HEX: 00000200 ; inline
-: WGL_SWAP_OVERLAY10 HEX: 00000400 ; inline
-: WGL_SWAP_OVERLAY11 HEX: 00000800 ; inline
-: WGL_SWAP_OVERLAY12 HEX: 00001000 ; inline
-: WGL_SWAP_OVERLAY13 HEX: 00002000 ; inline
-: WGL_SWAP_OVERLAY14 HEX: 00004000 ; inline
-: WGL_SWAP_OVERLAY15 HEX: 00008000 ; inline
-: WGL_SWAP_UNDERLAY1 HEX: 00010000 ; inline
-: WGL_SWAP_UNDERLAY2 HEX: 00020000 ; inline
-: WGL_SWAP_UNDERLAY3 HEX: 00040000 ; inline
-: WGL_SWAP_UNDERLAY4 HEX: 00080000 ; inline
-: WGL_SWAP_UNDERLAY5 HEX: 00100000 ; inline
-: WGL_SWAP_UNDERLAY6 HEX: 00200000 ; inline
-: WGL_SWAP_UNDERLAY7 HEX: 00400000 ; inline
-: WGL_SWAP_UNDERLAY8 HEX: 00800000 ; inline
-: WGL_SWAP_UNDERLAY9 HEX: 01000000 ; inline
-: WGL_SWAP_UNDERLAY10 HEX: 02000000 ; inline
-: WGL_SWAP_UNDERLAY11 HEX: 04000000 ; inline
-: WGL_SWAP_UNDERLAY12 HEX: 08000000 ; inline
-: WGL_SWAP_UNDERLAY13 HEX: 10000000 ; inline
-: WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline
-: WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline
+CONSTANT: WGL_SWAP_MAIN_PLANE HEX: 00000001
+CONSTANT: WGL_SWAP_OVERLAY1 HEX: 00000002
+CONSTANT: WGL_SWAP_OVERLAY2 HEX: 00000004
+CONSTANT: WGL_SWAP_OVERLAY3 HEX: 00000008
+CONSTANT: WGL_SWAP_OVERLAY4 HEX: 00000010
+CONSTANT: WGL_SWAP_OVERLAY5 HEX: 00000020
+CONSTANT: WGL_SWAP_OVERLAY6 HEX: 00000040
+CONSTANT: WGL_SWAP_OVERLAY7 HEX: 00000080
+CONSTANT: WGL_SWAP_OVERLAY8 HEX: 00000100
+CONSTANT: WGL_SWAP_OVERLAY9 HEX: 00000200
+CONSTANT: WGL_SWAP_OVERLAY10 HEX: 00000400
+CONSTANT: WGL_SWAP_OVERLAY11 HEX: 00000800
+CONSTANT: WGL_SWAP_OVERLAY12 HEX: 00001000
+CONSTANT: WGL_SWAP_OVERLAY13 HEX: 00002000
+CONSTANT: WGL_SWAP_OVERLAY14 HEX: 00004000
+CONSTANT: WGL_SWAP_OVERLAY15 HEX: 00008000
+CONSTANT: WGL_SWAP_UNDERLAY1 HEX: 00010000
+CONSTANT: WGL_SWAP_UNDERLAY2 HEX: 00020000
+CONSTANT: WGL_SWAP_UNDERLAY3 HEX: 00040000
+CONSTANT: WGL_SWAP_UNDERLAY4 HEX: 00080000
+CONSTANT: WGL_SWAP_UNDERLAY5 HEX: 00100000
+CONSTANT: WGL_SWAP_UNDERLAY6 HEX: 00200000
+CONSTANT: WGL_SWAP_UNDERLAY7 HEX: 00400000
+CONSTANT: WGL_SWAP_UNDERLAY8 HEX: 00800000
+CONSTANT: WGL_SWAP_UNDERLAY9 HEX: 01000000
+CONSTANT: WGL_SWAP_UNDERLAY10 HEX: 02000000
+CONSTANT: WGL_SWAP_UNDERLAY11 HEX: 04000000
+CONSTANT: WGL_SWAP_UNDERLAY12 HEX: 08000000
+CONSTANT: WGL_SWAP_UNDERLAY13 HEX: 10000000
+CONSTANT: WGL_SWAP_UNDERLAY14 HEX: 20000000
+CONSTANT: WGL_SWAP_UNDERLAY15 HEX: 40000000
: windowed-pfd-dwFlags ( -- n )
{ PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ;
TYPEDEF: ITEMID_CHILD* PITEMID_CHILD
TYPEDEF: ITEMID_CHILD* PCUITEMID_CHILD
-: STRRET_WSTR 0 ; inline
-: STRRET_OFFSET 1 ; inline
-: STRRET_CSTR 2 ; inline
+CONSTANT: STRRET_WSTR 0
+CONSTANT: STRRET_OFFSET 1
+CONSTANT: STRRET_CSTR 2
C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
C-STRUCT: STRRET
TYPEDEF: void* WNDPROC
-: FALSE 0 ; inline
-: TRUE 1 ; inline
+CONSTANT: FALSE 0
+CONSTANT: TRUE 1
-: >BOOLEAN ( ? -- 1/0 ) 1 0 ? ; inline
+: >BOOLEAN ( ? -- 1/0 ) TRUE FALSE ? ; inline
! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM);
!
! Standard Cursor IDs
!
-: IDC_ARROW 32512 ; inline
-: IDC_IBEAM 32513 ; inline
-: IDC_WAIT 32514 ; inline
-: IDC_CROSS 32515 ; inline
-: IDC_UPARROW 32516 ; inline
-: IDC_SIZE 32640 ; inline ! OBSOLETE: use IDC_SIZEALL
-: IDC_ICON 32641 ; inline ! OBSOLETE: use IDC_ARROW
-: IDC_SIZENWSE 32642 ; inline
-: IDC_SIZENESW 32643 ; inline
-: IDC_SIZEWE 32644 ; inline
-: IDC_SIZENS 32645 ; inline
-: IDC_SIZEALL 32646 ; inline
-: IDC_NO 32648 ; inline ! not in win3.1
-: IDC_HAND 32649 ; inline
-: IDC_APPSTARTING 32650 ; inline ! not in win3.1
-: IDC_HELP 32651 ; inline
+CONSTANT: IDC_ARROW 32512
+CONSTANT: IDC_IBEAM 32513
+CONSTANT: IDC_WAIT 32514
+CONSTANT: IDC_CROSS 32515
+CONSTANT: IDC_UPARROW 32516
+CONSTANT: IDC_SIZE 32640 ! OBSOLETE: use IDC_SIZEALL
+CONSTANT: IDC_ICON 32641 ! OBSOLETE: use IDC_ARROW
+CONSTANT: IDC_SIZENWSE 32642
+CONSTANT: IDC_SIZENESW 32643
+CONSTANT: IDC_SIZEWE 32644
+CONSTANT: IDC_SIZENS 32645
+CONSTANT: IDC_SIZEALL 32646
+CONSTANT: IDC_NO 32648 ! not in win3.1
+CONSTANT: IDC_HAND 32649
+CONSTANT: IDC_APPSTARTING 32650 ! not in win3.1
+CONSTANT: IDC_HELP 32651
! Predefined Clipboard Formats
-: CF_TEXT 1 ; inline
-: CF_BITMAP 2 ; inline
-: CF_METAFILEPICT 3 ; inline
-: CF_SYLK 4 ; inline
-: CF_DIF 5 ; inline
-: CF_TIFF 6 ; inline
-: CF_OEMTEXT 7 ; inline
-: CF_DIB 8 ; inline
-: CF_PALETTE 9 ; inline
-: CF_PENDATA 10 ; inline
-: CF_RIFF 11 ; inline
-: CF_WAVE 12 ; inline
-: CF_UNICODETEXT 13 ; inline
-: CF_ENHMETAFILE 14 ; inline
-: CF_HDROP 15 ; inline
-: CF_LOCALE 16 ; inline
-: CF_DIBV5 17 ; inline
-: CF_MAX 18 ; inline
-
-: CF_OWNERDISPLAY HEX: 0080 ; inline
-: CF_DSPTEXT HEX: 0081 ; inline
-: CF_DSPBITMAP HEX: 0082 ; inline
-: CF_DSPMETAFILEPICT HEX: 0083 ; inline
-: CF_DSPENHMETAFILE HEX: 008E ; inline
+CONSTANT: CF_TEXT 1
+CONSTANT: CF_BITMAP 2
+CONSTANT: CF_METAFILEPICT 3
+CONSTANT: CF_SYLK 4
+CONSTANT: CF_DIF 5
+CONSTANT: CF_TIFF 6
+CONSTANT: CF_OEMTEXT 7
+CONSTANT: CF_DIB 8
+CONSTANT: CF_PALETTE 9
+CONSTANT: CF_PENDATA 10
+CONSTANT: CF_RIFF 11
+CONSTANT: CF_WAVE 12
+CONSTANT: CF_UNICODETEXT 13
+CONSTANT: CF_ENHMETAFILE 14
+CONSTANT: CF_HDROP 15
+CONSTANT: CF_LOCALE 16
+CONSTANT: CF_DIBV5 17
+CONSTANT: CF_MAX 18
+
+CONSTANT: CF_OWNERDISPLAY HEX: 0080
+CONSTANT: CF_DSPTEXT HEX: 0081
+CONSTANT: CF_DSPBITMAP HEX: 0082
+CONSTANT: CF_DSPMETAFILEPICT HEX: 0083
+CONSTANT: CF_DSPENHMETAFILE HEX: 008E
! "Private" formats don't get GlobalFree()'d
-: CF_PRIVATEFIRST HEX: 200 ; inline
-: CF_PRIVATELAST HEX: 2FF ; inline
+CONSTANT: CF_PRIVATEFIRST HEX: 200
+CONSTANT: CF_PRIVATELAST HEX: 2FF
! "GDIOBJ" formats do get DeleteObject()'d
-: CF_GDIOBJFIRST HEX: 300 ; inline
-: CF_GDIOBJLAST HEX: 3FF ; inline
+CONSTANT: CF_GDIOBJFIRST HEX: 300
+CONSTANT: CF_GDIOBJLAST HEX: 3FF
! Virtual Keys, Standard Set
-: VK_LBUTTON HEX: 01 ; inline
-: VK_RBUTTON HEX: 02 ; inline
-: VK_CANCEL HEX: 03 ; inline
-: VK_MBUTTON HEX: 04 ; inline ! NOT contiguous with L & RBUTTON
-: VK_XBUTTON1 HEX: 05 ; inline ! NOT contiguous with L & RBUTTON
-: VK_XBUTTON2 HEX: 06 ; inline ! NOT contiguous with L & RBUTTON
+CONSTANT: VK_LBUTTON HEX: 01
+CONSTANT: VK_RBUTTON HEX: 02
+CONSTANT: VK_CANCEL HEX: 03
+CONSTANT: VK_MBUTTON HEX: 04 ! NOT contiguous with L & RBUTTON
+CONSTANT: VK_XBUTTON1 HEX: 05 ! NOT contiguous with L & RBUTTON
+CONSTANT: VK_XBUTTON2 HEX: 06 ! NOT contiguous with L & RBUTTON
! 0x07 : unassigned
-: VK_BACK HEX: 08 ; inline
-: VK_TAB HEX: 09 ; inline
+CONSTANT: VK_BACK HEX: 08
+CONSTANT: VK_TAB HEX: 09
! 0x0A - 0x0B : reserved
-: VK_CLEAR HEX: 0C ; inline
-: VK_RETURN HEX: 0D ; inline
-
-: VK_SHIFT HEX: 10 ; inline
-: VK_CONTROL HEX: 11 ; inline
-: VK_MENU HEX: 12 ; inline
-: VK_PAUSE HEX: 13 ; inline
-: VK_CAPITAL HEX: 14 ; inline
-
-: VK_KANA HEX: 15 ; inline
-: VK_HANGEUL HEX: 15 ; inline ! old name - here for compatibility
-: VK_HANGUL HEX: 15 ; inline
-: VK_JUNJA HEX: 17 ; inline
-: VK_FINAL HEX: 18 ; inline
-: VK_HANJA HEX: 19 ; inline
-: VK_KANJI HEX: 19 ; inline
-
-: VK_ESCAPE HEX: 1B ; inline
-
-: VK_CONVERT HEX: 1C ; inline
-: VK_NONCONVERT HEX: 1D ; inline
-: VK_ACCEPT HEX: 1E ; inline
-: VK_MODECHANGE HEX: 1F ; inline
-
-: VK_SPACE HEX: 20 ; inline
-: VK_PRIOR HEX: 21 ; inline
-: VK_NEXT HEX: 22 ; inline
-: VK_END HEX: 23 ; inline
-: VK_HOME HEX: 24 ; inline
-: VK_LEFT HEX: 25 ; inline
-: VK_UP HEX: 26 ; inline
-: VK_RIGHT HEX: 27 ; inline
-: VK_DOWN HEX: 28 ; inline
-: VK_SELECT HEX: 29 ; inline
-: VK_PRINT HEX: 2A ; inline
-: VK_EXECUTE HEX: 2B ; inline
-: VK_SNAPSHOT HEX: 2C ; inline
-: VK_INSERT HEX: 2D ; inline
-: VK_DELETE HEX: 2E ; inline
-: VK_HELP HEX: 2F ; inline
-
-: VK_0 CHAR: 0 ; inline
-: VK_1 CHAR: 1 ; inline
-: VK_2 CHAR: 2 ; inline
-: VK_3 CHAR: 3 ; inline
-: VK_4 CHAR: 4 ; inline
-: VK_5 CHAR: 5 ; inline
-: VK_6 CHAR: 6 ; inline
-: VK_7 CHAR: 7 ; inline
-: VK_8 CHAR: 8 ; inline
-: VK_9 CHAR: 9 ; inline
-
-: VK_A CHAR: A ; inline
-: VK_B CHAR: B ; inline
-: VK_C CHAR: C ; inline
-: VK_D CHAR: D ; inline
-: VK_E CHAR: E ; inline
-: VK_F CHAR: F ; inline
-: VK_G CHAR: G ; inline
-: VK_H CHAR: H ; inline
-: VK_I CHAR: I ; inline
-: VK_J CHAR: J ; inline
-: VK_K CHAR: K ; inline
-: VK_L CHAR: L ; inline
-: VK_M CHAR: M ; inline
-: VK_N CHAR: N ; inline
-: VK_O CHAR: O ; inline
-: VK_P CHAR: P ; inline
-: VK_Q CHAR: Q ; inline
-: VK_R CHAR: R ; inline
-: VK_S CHAR: S ; inline
-: VK_T CHAR: T ; inline
-: VK_U CHAR: U ; inline
-: VK_V CHAR: V ; inline
-: VK_W CHAR: W ; inline
-: VK_X CHAR: X ; inline
-: VK_Y CHAR: Y ; inline
-: VK_Z CHAR: Z ; inline
-
-: VK_LWIN HEX: 5B ; inline
-: VK_RWIN HEX: 5C ; inline
-: VK_APPS HEX: 5D ; inline
+CONSTANT: VK_CLEAR HEX: 0C
+CONSTANT: VK_RETURN HEX: 0D
+
+CONSTANT: VK_SHIFT HEX: 10
+CONSTANT: VK_CONTROL HEX: 11
+CONSTANT: VK_MENU HEX: 12
+CONSTANT: VK_PAUSE HEX: 13
+CONSTANT: VK_CAPITAL HEX: 14
+
+CONSTANT: VK_KANA HEX: 15
+CONSTANT: VK_HANGEUL HEX: 15 ! old name - here for compatibility
+CONSTANT: VK_HANGUL HEX: 15
+CONSTANT: VK_JUNJA HEX: 17
+CONSTANT: VK_FINAL HEX: 18
+CONSTANT: VK_HANJA HEX: 19
+CONSTANT: VK_KANJI HEX: 19
+
+CONSTANT: VK_ESCAPE HEX: 1B
+
+CONSTANT: VK_CONVERT HEX: 1C
+CONSTANT: VK_NONCONVERT HEX: 1D
+CONSTANT: VK_ACCEPT HEX: 1E
+CONSTANT: VK_MODECHANGE HEX: 1F
+
+CONSTANT: VK_SPACE HEX: 20
+CONSTANT: VK_PRIOR HEX: 21
+CONSTANT: VK_NEXT HEX: 22
+CONSTANT: VK_END HEX: 23
+CONSTANT: VK_HOME HEX: 24
+CONSTANT: VK_LEFT HEX: 25
+CONSTANT: VK_UP HEX: 26
+CONSTANT: VK_RIGHT HEX: 27
+CONSTANT: VK_DOWN HEX: 28
+CONSTANT: VK_SELECT HEX: 29
+CONSTANT: VK_PRINT HEX: 2A
+CONSTANT: VK_EXECUTE HEX: 2B
+CONSTANT: VK_SNAPSHOT HEX: 2C
+CONSTANT: VK_INSERT HEX: 2D
+CONSTANT: VK_DELETE HEX: 2E
+CONSTANT: VK_HELP HEX: 2F
+
+CONSTANT: VK_0 CHAR: 0
+CONSTANT: VK_1 CHAR: 1
+CONSTANT: VK_2 CHAR: 2
+CONSTANT: VK_3 CHAR: 3
+CONSTANT: VK_4 CHAR: 4
+CONSTANT: VK_5 CHAR: 5
+CONSTANT: VK_6 CHAR: 6
+CONSTANT: VK_7 CHAR: 7
+CONSTANT: VK_8 CHAR: 8
+CONSTANT: VK_9 CHAR: 9
+
+CONSTANT: VK_A CHAR: A
+CONSTANT: VK_B CHAR: B
+CONSTANT: VK_C CHAR: C
+CONSTANT: VK_D CHAR: D
+CONSTANT: VK_E CHAR: E
+CONSTANT: VK_F CHAR: F
+CONSTANT: VK_G CHAR: G
+CONSTANT: VK_H CHAR: H
+CONSTANT: VK_I CHAR: I
+CONSTANT: VK_J CHAR: J
+CONSTANT: VK_K CHAR: K
+CONSTANT: VK_L CHAR: L
+CONSTANT: VK_M CHAR: M
+CONSTANT: VK_N CHAR: N
+CONSTANT: VK_O CHAR: O
+CONSTANT: VK_P CHAR: P
+CONSTANT: VK_Q CHAR: Q
+CONSTANT: VK_R CHAR: R
+CONSTANT: VK_S CHAR: S
+CONSTANT: VK_T CHAR: T
+CONSTANT: VK_U CHAR: U
+CONSTANT: VK_V CHAR: V
+CONSTANT: VK_W CHAR: W
+CONSTANT: VK_X CHAR: X
+CONSTANT: VK_Y CHAR: Y
+CONSTANT: VK_Z CHAR: Z
+
+CONSTANT: VK_LWIN HEX: 5B
+CONSTANT: VK_RWIN HEX: 5C
+CONSTANT: VK_APPS HEX: 5D
! 0x5E : reserved
-: VK_SLEEP HEX: 5F ; inline
-
-: VK_NUMPAD0 HEX: 60 ; inline
-: VK_NUMPAD1 HEX: 61 ; inline
-: VK_NUMPAD2 HEX: 62 ; inline
-: VK_NUMPAD3 HEX: 63 ; inline
-: VK_NUMPAD4 HEX: 64 ; inline
-: VK_NUMPAD5 HEX: 65 ; inline
-: VK_NUMPAD6 HEX: 66 ; inline
-: VK_NUMPAD7 HEX: 67 ; inline
-: VK_NUMPAD8 HEX: 68 ; inline
-: VK_NUMPAD9 HEX: 69 ; inline
-: VK_MULTIPLY HEX: 6A ; inline
-: VK_ADD HEX: 6B ; inline
-: VK_SEPARATOR HEX: 6C ; inline
-: VK_SUBTRACT HEX: 6D ; inline
-: VK_DECIMAL HEX: 6E ; inline
-: VK_DIVIDE HEX: 6F ; inline
-: VK_F1 HEX: 70 ; inline
-: VK_F2 HEX: 71 ; inline
-: VK_F3 HEX: 72 ; inline
-: VK_F4 HEX: 73 ; inline
-: VK_F5 HEX: 74 ; inline
-: VK_F6 HEX: 75 ; inline
-: VK_F7 HEX: 76 ; inline
-: VK_F8 HEX: 77 ; inline
-: VK_F9 HEX: 78 ; inline
-: VK_F10 HEX: 79 ; inline
-: VK_F11 HEX: 7A ; inline
-: VK_F12 HEX: 7B ; inline
-: VK_F13 HEX: 7C ; inline
-: VK_F14 HEX: 7D ; inline
-: VK_F15 HEX: 7E ; inline
-: VK_F16 HEX: 7F ; inline
-: VK_F17 HEX: 80 ; inline
-: VK_F18 HEX: 81 ; inline
-: VK_F19 HEX: 82 ; inline
-: VK_F20 HEX: 83 ; inline
-: VK_F21 HEX: 84 ; inline
-: VK_F22 HEX: 85 ; inline
-: VK_F23 HEX: 86 ; inline
-: VK_F24 HEX: 87 ; inline
+CONSTANT: VK_SLEEP HEX: 5F
+
+CONSTANT: VK_NUMPAD0 HEX: 60
+CONSTANT: VK_NUMPAD1 HEX: 61
+CONSTANT: VK_NUMPAD2 HEX: 62
+CONSTANT: VK_NUMPAD3 HEX: 63
+CONSTANT: VK_NUMPAD4 HEX: 64
+CONSTANT: VK_NUMPAD5 HEX: 65
+CONSTANT: VK_NUMPAD6 HEX: 66
+CONSTANT: VK_NUMPAD7 HEX: 67
+CONSTANT: VK_NUMPAD8 HEX: 68
+CONSTANT: VK_NUMPAD9 HEX: 69
+CONSTANT: VK_MULTIPLY HEX: 6A
+CONSTANT: VK_ADD HEX: 6B
+CONSTANT: VK_SEPARATOR HEX: 6C
+CONSTANT: VK_SUBTRACT HEX: 6D
+CONSTANT: VK_DECIMAL HEX: 6E
+CONSTANT: VK_DIVIDE HEX: 6F
+CONSTANT: VK_F1 HEX: 70
+CONSTANT: VK_F2 HEX: 71
+CONSTANT: VK_F3 HEX: 72
+CONSTANT: VK_F4 HEX: 73
+CONSTANT: VK_F5 HEX: 74
+CONSTANT: VK_F6 HEX: 75
+CONSTANT: VK_F7 HEX: 76
+CONSTANT: VK_F8 HEX: 77
+CONSTANT: VK_F9 HEX: 78
+CONSTANT: VK_F10 HEX: 79
+CONSTANT: VK_F11 HEX: 7A
+CONSTANT: VK_F12 HEX: 7B
+CONSTANT: VK_F13 HEX: 7C
+CONSTANT: VK_F14 HEX: 7D
+CONSTANT: VK_F15 HEX: 7E
+CONSTANT: VK_F16 HEX: 7F
+CONSTANT: VK_F17 HEX: 80
+CONSTANT: VK_F18 HEX: 81
+CONSTANT: VK_F19 HEX: 82
+CONSTANT: VK_F20 HEX: 83
+CONSTANT: VK_F21 HEX: 84
+CONSTANT: VK_F22 HEX: 85
+CONSTANT: VK_F23 HEX: 86
+CONSTANT: VK_F24 HEX: 87
! 0x88 - 0x8F : unassigned
-: VK_NUMLOCK HEX: 90 ; inline
-: VK_SCROLL HEX: 91 ; inline
+CONSTANT: VK_NUMLOCK HEX: 90
+CONSTANT: VK_SCROLL HEX: 91
! NEC PC-9800 kbd definitions
-: VK_OEM_NEC_EQUAL HEX: 92 ; inline ! '=' key on numpad
+CONSTANT: VK_OEM_NEC_EQUAL HEX: 92 ! '=' key on numpad
! Fujitsu/OASYS kbd definitions
-: VK_OEM_FJ_JISHO HEX: 92 ; inline ! 'Dictionary' key
-: VK_OEM_FJ_MASSHOU HEX: 93 ; inline ! 'Unregister word' key
-: VK_OEM_FJ_TOUROKU HEX: 94 ; inline ! 'Register word' key
-: VK_OEM_FJ_LOYA HEX: 95 ; inline ! 'Left OYAYUBI' key
-: VK_OEM_FJ_ROYA HEX: 96 ; inline ! 'Right OYAYUBI' key
+CONSTANT: VK_OEM_FJ_JISHO HEX: 92 ! 'Dictionary' key
+CONSTANT: VK_OEM_FJ_MASSHOU HEX: 93 ! 'Unregister word' key
+CONSTANT: VK_OEM_FJ_TOUROKU HEX: 94 ! 'Register word' key
+CONSTANT: VK_OEM_FJ_LOYA HEX: 95 ! 'Left OYAYUBI' key
+CONSTANT: VK_OEM_FJ_ROYA HEX: 96 ! 'Right OYAYUBI' key
! 0x97 - 0x9F : unassigned
! VK_L* & VK_R* - left and right Alt, Ctrl and Shift virtual keys.
! Used only as parameters to GetAsyncKeyState() and GetKeyState().
! No other API or message will distinguish left and right keys in this way.
-: VK_LSHIFT HEX: A0 ; inline
-: VK_RSHIFT HEX: A1 ; inline
-: VK_LCONTROL HEX: A2 ; inline
-: VK_RCONTROL HEX: A3 ; inline
-: VK_LMENU HEX: A4 ; inline
-: VK_RMENU HEX: A5 ; inline
-
-: VK_BROWSER_BACK HEX: A6 ; inline
-: VK_BROWSER_FORWARD HEX: A7 ; inline
-: VK_BROWSER_REFRESH HEX: A8 ; inline
-: VK_BROWSER_STOP HEX: A9 ; inline
-: VK_BROWSER_SEARCH HEX: AA ; inline
-: VK_BROWSER_FAVORITES HEX: AB ; inline
-: VK_BROWSER_HOME HEX: AC ; inline
-
-: VK_VOLUME_MUTE HEX: AD ; inline
-: VK_VOLUME_DOWN HEX: AE ; inline
-: VK_VOLUME_UP HEX: AF ; inline
-: VK_MEDIA_NEXT_TRACK HEX: B0 ; inline
-: VK_MEDIA_PREV_TRACK HEX: B1 ; inline
-: VK_MEDIA_STOP HEX: B2 ; inline
-: VK_MEDIA_PLAY_PAUSE HEX: B3 ; inline
-: VK_LAUNCH_MAIL HEX: B4 ; inline
-: VK_LAUNCH_MEDIA_SELECT HEX: B5 ; inline
-: VK_LAUNCH_APP1 HEX: B6 ; inline
-: VK_LAUNCH_APP2 HEX: B7 ; inline
+CONSTANT: VK_LSHIFT HEX: A0
+CONSTANT: VK_RSHIFT HEX: A1
+CONSTANT: VK_LCONTROL HEX: A2
+CONSTANT: VK_RCONTROL HEX: A3
+CONSTANT: VK_LMENU HEX: A4
+CONSTANT: VK_RMENU HEX: A5
+
+CONSTANT: VK_BROWSER_BACK HEX: A6
+CONSTANT: VK_BROWSER_FORWARD HEX: A7
+CONSTANT: VK_BROWSER_REFRESH HEX: A8
+CONSTANT: VK_BROWSER_STOP HEX: A9
+CONSTANT: VK_BROWSER_SEARCH HEX: AA
+CONSTANT: VK_BROWSER_FAVORITES HEX: AB
+CONSTANT: VK_BROWSER_HOME HEX: AC
+
+CONSTANT: VK_VOLUME_MUTE HEX: AD
+CONSTANT: VK_VOLUME_DOWN HEX: AE
+CONSTANT: VK_VOLUME_UP HEX: AF
+CONSTANT: VK_MEDIA_NEXT_TRACK HEX: B0
+CONSTANT: VK_MEDIA_PREV_TRACK HEX: B1
+CONSTANT: VK_MEDIA_STOP HEX: B2
+CONSTANT: VK_MEDIA_PLAY_PAUSE HEX: B3
+CONSTANT: VK_LAUNCH_MAIL HEX: B4
+CONSTANT: VK_LAUNCH_MEDIA_SELECT HEX: B5
+CONSTANT: VK_LAUNCH_APP1 HEX: B6
+CONSTANT: VK_LAUNCH_APP2 HEX: B7
! 0xB8 - 0xB9 : reserved
-: VK_OEM_1 HEX: BA ; inline ! ';:' for US
-: VK_OEM_PLUS HEX: BB ; inline ! '+' any country
-: VK_OEM_COMMA HEX: BC ; inline ! ',' any country
-: VK_OEM_MINUS HEX: BD ; inline ! '-' any country
-: VK_OEM_PERIOD HEX: BE ; inline ! '.' any country
-: VK_OEM_2 HEX: BF ; inline ! '/?' for US
-: VK_OEM_3 HEX: C0 ; inline ! '`~' for US
+CONSTANT: VK_OEM_1 HEX: BA ! ';:' for US
+CONSTANT: VK_OEM_PLUS HEX: BB ! '+' any country
+CONSTANT: VK_OEM_COMMA HEX: BC ! ',' any country
+CONSTANT: VK_OEM_MINUS HEX: BD ! '-' any country
+CONSTANT: VK_OEM_PERIOD HEX: BE ! '.' any country
+CONSTANT: VK_OEM_2 HEX: BF ! '/?' for US
+CONSTANT: VK_OEM_3 HEX: C0 ! '`~' for US
! 0xC1 - 0xD7 : reserved
! 0xD8 - 0xDA : unassigned
-: VK_OEM_4 HEX: DB ; inline ! '[{' for US
-: VK_OEM_5 HEX: DC ; inline ! '\|' for US
-: VK_OEM_6 HEX: DD ; inline ! ']}' for US
-: VK_OEM_7 HEX: DE ; inline ! ''"' for US
-: VK_OEM_8 HEX: DF ; inline
+CONSTANT: VK_OEM_4 HEX: DB ! '[{' for US
+CONSTANT: VK_OEM_5 HEX: DC ! '\|' for US
+CONSTANT: VK_OEM_6 HEX: DD ! ']}' for US
+CONSTANT: VK_OEM_7 HEX: DE ! ''"' for US
+CONSTANT: VK_OEM_8 HEX: DF
! 0xE0 : reserved
! Various extended or enhanced keyboards
-: VK_OEM_AX HEX: E1 ; inline ! 'AX' key on Japanese AX kbd
-: VK_OEM_102 HEX: E2 ; inline ! "<>" or "\|" on RT 102-key kbd.
-: VK_ICO_HELP HEX: E3 ; inline ! Help key on ICO
-: VK_ICO_00 HEX: E4 ; inline ! 00 key on ICO
+CONSTANT: VK_OEM_AX HEX: E1 ! 'AX' key on Japanese AX kbd
+CONSTANT: VK_OEM_102 HEX: E2 ! "<>" or "\|" on RT 102-key kbd.
+CONSTANT: VK_ICO_HELP HEX: E3 ! Help key on ICO
+CONSTANT: VK_ICO_00 HEX: E4 ! 00 key on ICO
-: VK_PROCESSKEY HEX: E5 ; inline
+CONSTANT: VK_PROCESSKEY HEX: E5
-: VK_ICO_CLEAR HEX: E6 ; inline
+CONSTANT: VK_ICO_CLEAR HEX: E6
-: VK_PACKET HEX: E7 ; inline
+CONSTANT: VK_PACKET HEX: E7
! 0xE8 : unassigned
! Nokia/Ericsson definitions
-: VK_OEM_RESET HEX: E9 ; inline
-: VK_OEM_JUMP HEX: EA ; inline
-: VK_OEM_PA1 HEX: EB ; inline
-: VK_OEM_PA2 HEX: EC ; inline
-: VK_OEM_PA3 HEX: ED ; inline
-: VK_OEM_WSCTRL HEX: EE ; inline
-: VK_OEM_CUSEL HEX: EF ; inline
-: VK_OEM_ATTN HEX: F0 ; inline
-: VK_OEM_FINISH HEX: F1 ; inline
-: VK_OEM_COPY HEX: F2 ; inline
-: VK_OEM_AUTO HEX: F3 ; inline
-: VK_OEM_ENLW HEX: F4 ; inline
-: VK_OEM_BACKTAB HEX: F5 ; inline
-
-: VK_ATTN HEX: F6 ; inline
-: VK_CRSEL HEX: F7 ; inline
-: VK_EXSEL HEX: F8 ; inline
-: VK_EREOF HEX: F9 ; inline
-: VK_PLAY HEX: FA ; inline
-: VK_ZOOM HEX: FB ; inline
-: VK_NONAME HEX: FC ; inline
-: VK_PA1 HEX: FD ; inline
-: VK_OEM_CLEAR HEX: FE ; inline
+CONSTANT: VK_OEM_RESET HEX: E9
+CONSTANT: VK_OEM_JUMP HEX: EA
+CONSTANT: VK_OEM_PA1 HEX: EB
+CONSTANT: VK_OEM_PA2 HEX: EC
+CONSTANT: VK_OEM_PA3 HEX: ED
+CONSTANT: VK_OEM_WSCTRL HEX: EE
+CONSTANT: VK_OEM_CUSEL HEX: EF
+CONSTANT: VK_OEM_ATTN HEX: F0
+CONSTANT: VK_OEM_FINISH HEX: F1
+CONSTANT: VK_OEM_COPY HEX: F2
+CONSTANT: VK_OEM_AUTO HEX: F3
+CONSTANT: VK_OEM_ENLW HEX: F4
+CONSTANT: VK_OEM_BACKTAB HEX: F5
+
+CONSTANT: VK_ATTN HEX: F6
+CONSTANT: VK_CRSEL HEX: F7
+CONSTANT: VK_EXSEL HEX: F8
+CONSTANT: VK_EREOF HEX: F9
+CONSTANT: VK_PLAY HEX: FA
+CONSTANT: VK_ZOOM HEX: FB
+CONSTANT: VK_NONAME HEX: FC
+CONSTANT: VK_PA1 HEX: FD
+CONSTANT: VK_OEM_CLEAR HEX: FE
! 0xFF : reserved
! Key State Masks for Mouse Messages
-: MK_LBUTTON HEX: 0001 ; inline
-: MK_RBUTTON HEX: 0002 ; inline
-: MK_SHIFT HEX: 0004 ; inline
-: MK_CONTROL HEX: 0008 ; inline
-: MK_MBUTTON HEX: 0010 ; inline
-: MK_XBUTTON1 HEX: 0020 ; inline
-: MK_XBUTTON2 HEX: 0040 ; inline
+CONSTANT: MK_LBUTTON HEX: 0001
+CONSTANT: MK_RBUTTON HEX: 0002
+CONSTANT: MK_SHIFT HEX: 0004
+CONSTANT: MK_CONTROL HEX: 0008
+CONSTANT: MK_MBUTTON HEX: 0010
+CONSTANT: MK_XBUTTON1 HEX: 0020
+CONSTANT: MK_XBUTTON2 HEX: 0040
! Some fields are not defined for win64
! Window field offsets for GetWindowLong()
-: GWL_WNDPROC -4 ; inline
-: GWL_HINSTANCE -6 ; inline
-: GWL_HWNDPARENT -8 ; inline
-: GWL_USERDATA -21 ; inline
-: GWL_ID -12 ; inline
+CONSTANT: GWL_WNDPROC -4
+CONSTANT: GWL_HINSTANCE -6
+CONSTANT: GWL_HWNDPARENT -8
+CONSTANT: GWL_USERDATA -21
+CONSTANT: GWL_ID -12
-: GWL_STYLE -16 ; inline
-: GWL_EXSTYLE -20 ; inline
+CONSTANT: GWL_STYLE -16
+CONSTANT: GWL_EXSTYLE -20
-: GWLP_WNDPROC -4 ; inline
-: GWLP_HINSTANCE -6 ; inline
-: GWLP_HWNDPARENT -8 ; inline
-: GWLP_USERDATA -21 ; inline
-: GWLP_ID -12 ; inline
+CONSTANT: GWLP_WNDPROC -4
+CONSTANT: GWLP_HINSTANCE -6
+CONSTANT: GWLP_HWNDPARENT -8
+CONSTANT: GWLP_USERDATA -21
+CONSTANT: GWLP_ID -12
! Class field offsets for GetClassLong()
-: GCL_MENUNAME -8 ; inline
-: GCL_HBRBACKGROUND -10 ; inline
-: GCL_HCURSOR -12 ; inline
-: GCL_HICON -14 ; inline
-: GCL_HMODULE -16 ; inline
-: GCL_WNDPROC -24 ; inline
-: GCL_HICONSM -34 ; inline
-: GCL_CBWNDEXTRA -18 ; inline
-: GCL_CBCLSEXTRA -20 ; inline
-: GCL_STYLE -26 ; inline
-: GCW_ATOM -32 ; inline
-
-: GCLP_MENUNAME -8 ; inline
-: GCLP_HBRBACKGROUND -10 ; inline
-: GCLP_HCURSOR -12 ; inline
-: GCLP_HICON -14 ; inline
-: GCLP_HMODULE -16 ; inline
-: GCLP_WNDPROC -24 ; inline
-: GCLP_HICONSM -34 ; inline
-
-: MB_ICONASTERISK HEX: 00000040 ; inline
-: MB_ICONEXCLAMATION HEX: 00000030 ; inline
-: MB_ICONHAND HEX: 00000010 ; inline
-: MB_ICONQUESTION HEX: 00000020 ; inline
-: MB_OK HEX: 00000000 ; inline
+CONSTANT: GCL_MENUNAME -8
+CONSTANT: GCL_HBRBACKGROUND -10
+CONSTANT: GCL_HCURSOR -12
+CONSTANT: GCL_HICON -14
+CONSTANT: GCL_HMODULE -16
+CONSTANT: GCL_WNDPROC -24
+CONSTANT: GCL_HICONSM -34
+CONSTANT: GCL_CBWNDEXTRA -18
+CONSTANT: GCL_CBCLSEXTRA -20
+CONSTANT: GCL_STYLE -26
+CONSTANT: GCW_ATOM -32
+
+CONSTANT: GCLP_MENUNAME -8
+CONSTANT: GCLP_HBRBACKGROUND -10
+CONSTANT: GCLP_HCURSOR -12
+CONSTANT: GCLP_HICON -14
+CONSTANT: GCLP_HMODULE -16
+CONSTANT: GCLP_WNDPROC -24
+CONSTANT: GCLP_HICONSM -34
+
+CONSTANT: MB_ICONASTERISK HEX: 00000040
+CONSTANT: MB_ICONEXCLAMATION HEX: 00000030
+CONSTANT: MB_ICONHAND HEX: 00000010
+CONSTANT: MB_ICONQUESTION HEX: 00000020
+CONSTANT: MB_OK HEX: 00000000
ALIAS: FVIRTKEY TRUE
-: FNOINVERT 2 ; inline
-: FSHIFT 4 ; inline
-: FCONTROL 8 ; inline
-: FALT 16 ; inline
-
-: MAPVK_VK_TO_VSC 0 ; inline
-: MAPVK_VSC_TO_VK 1 ; inline
-: MAPVK_VK_TO_CHAR 2 ; inline
-: MAPVK_VSC_TO_VK_EX 3 ; inline
-: MAPVK_VK_TO_VSC_EX 3 ; inline
-
-: TME_HOVER 1 ; inline
-: TME_LEAVE 2 ; inline
-: TME_NONCLIENT 16 ; inline
-: TME_QUERY HEX: 40000000 ; inline
-: TME_CANCEL HEX: 80000000 ; inline
-: HOVER_DEFAULT HEX: ffffffff ; inline
+CONSTANT: FNOINVERT 2
+CONSTANT: FSHIFT 4
+CONSTANT: FCONTROL 8
+CONSTANT: FALT 16
+
+CONSTANT: MAPVK_VK_TO_VSC 0
+CONSTANT: MAPVK_VSC_TO_VK 1
+CONSTANT: MAPVK_VK_TO_CHAR 2
+CONSTANT: MAPVK_VSC_TO_VK_EX 3
+CONSTANT: MAPVK_VK_TO_VSC_EX 3
+
+CONSTANT: TME_HOVER 1
+CONSTANT: TME_LEAVE 2
+CONSTANT: TME_NONCLIENT 16
+CONSTANT: TME_QUERY HEX: 40000000
+CONSTANT: TME_CANCEL HEX: 80000000
+CONSTANT: HOVER_DEFAULT HEX: ffffffff
C-STRUCT: TRACKMOUSEEVENT
{ "DWORD" "cbSize" }
{ "DWORD" "dwFlags" }
{ "DWORD" "dwHoverTime" } ;
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
-: DBT_DEVICEARRIVAL HEX: 8000 ; inline
-: DBT_DEVICEREMOVECOMPLETE HEX: 8004 ; inline
+CONSTANT: DBT_DEVICEARRIVAL HEX: 8000
+CONSTANT: DBT_DEVICEREMOVECOMPLETE HEX: 8004
-: DBT_DEVTYP_DEVICEINTERFACE 5 ; inline
+CONSTANT: DBT_DEVTYP_DEVICEINTERFACE 5
-: DEVICE_NOTIFY_WINDOW_HANDLE 0 ; inline
-: DEVICE_NOTIFY_SERVICE_HANDLE 1 ; inline
+CONSTANT: DEVICE_NOTIFY_WINDOW_HANDLE 0
+CONSTANT: DEVICE_NOTIFY_SERVICE_HANDLE 1
-: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4 ; inline
+CONSTANT: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4
C-STRUCT: DEV_BROADCAST_HDR
{ "DWORD" "dbch_size" }
: CreateWindow ( a b c d e f g h i j k -- hwnd ) 0 12 -nrot CreateWindowEx ; inline
-
! FUNCTION: CreateWindowStationA
! FUNCTION: CreateWindowStationW
! FUNCTION: CsrBroadcastSystemMessageExW
: lo-word ( wparam -- lo ) <short> *short ; inline
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
-: MAX_UNICODE_PATH 32768 ; inline
+CONSTANT: MAX_UNICODE_PATH 32768
! You must LocalFree the return value!
FUNCTION: void* error_message ( DWORD id ) ;
TYPEDEF: WSANAMESPACE_INFO* PWSANAMESPACE_INFO
TYPEDEF: WSANAMESPACE_INFO* LPWSANAMESPACE_INFO
-: FD_MAX_EVENTS 10 ;
+CONSTANT: FD_MAX_EVENTS 10
C-STRUCT: WSANETWORKEVENTS
{ "long" "lNetworkEvents" }
- ! { { "int" "FD_MAX_EVENTS" } "iErrorCode" } ;
- { { "int" 10 } "iErrorCode" } ;
+ { { "int" FD_MAX_EVENTS } "iErrorCode" } ;
TYPEDEF: WSANETWORKEVENTS* PWSANETWORKEVENTS
TYPEDEF: WSANETWORKEVENTS* LPWSANETWORKEVENTS
! 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.
! 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
! 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
! 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
! 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
! 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
! used in QueryFont -- draw direction
-: FontLeftToRight 0 ;
-: FontRightToLeft 1 ;
+CONSTANT: FontLeftToRight 0
+CONSTANT: FontRightToLeft 1
-: FontChange 255 ;
+CONSTANT: FontChange 255
! *****************************************************************
! * IMAGING
! 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
! 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
! 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
: 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
! 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
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
XNResourceClass over 0 XCreateIC
[ "XCreateIC() failed" throw ] unless* ;
-: buf-size 100 ;
+CONSTANT: buf-size 100
SYMBOL: keybuf
SYMBOL: keysym
{ "Colormap" "colormap" }
{ "Cursor" "cursor" } ;
-: UnmapGravity 0 ; inline
-
-: ForgetGravity 0 ; inline
-: NorthWestGravity 1 ; inline
-: NorthGravity 2 ; inline
-: NorthEastGravity 3 ; inline
-: WestGravity 4 ; inline
-: CenterGravity 5 ; inline
-: EastGravity 6 ; inline
-: SouthWestGravity 7 ; inline
-: SouthGravity 8 ; inline
-: SouthEastGravity 9 ; inline
-: StaticGravity 10 ; inline
+CONSTANT: UnmapGravity 0
+
+CONSTANT: ForgetGravity 0
+CONSTANT: NorthWestGravity 1
+CONSTANT: NorthGravity 2
+CONSTANT: NorthEastGravity 3
+CONSTANT: WestGravity 4
+CONSTANT: CenterGravity 5
+CONSTANT: EastGravity 6
+CONSTANT: SouthWestGravity 7
+CONSTANT: SouthGravity 8
+CONSTANT: SouthEastGravity 9
+CONSTANT: StaticGravity 10
! 3.3 - Creating Windows
FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ;
-: IsUnmapped 0 ; inline
-: IsUnviewable 1 ; inline
-: IsViewable 2 ; inline
+CONSTANT: IsUnmapped 0
+CONSTANT: IsUnviewable 1
+CONSTANT: IsViewable 2
FUNCTION: Status XGetGeometry (
Display* display,
: GCDashList ( -- n ) 21 2^ ; inline
: GCArcMode ( -- n ) 22 2^ ; inline
-: GXclear HEX: 0 ; inline
-: GXand HEX: 1 ; inline
-: GXandReverse HEX: 2 ; inline
-: GXcopy HEX: 3 ; inline
-: GXandInverted HEX: 4 ; inline
-: GXnoop HEX: 5 ; inline
-: GXxor HEX: 6 ; inline
-: GXor HEX: 7 ; inline
-: GXnor HEX: 8 ; inline
-: GXequiv HEX: 9 ; inline
-: GXinvert HEX: a ; inline
-: GXorReverse HEX: b ; inline
-: GXcopyInverted HEX: c ; inline
-: GXorInverted HEX: d ; inline
-: GXnand HEX: e ; inline
-: GXset HEX: f ; inline
+CONSTANT: GXclear HEX: 0
+CONSTANT: GXand HEX: 1
+CONSTANT: GXandReverse HEX: 2
+CONSTANT: GXcopy HEX: 3
+CONSTANT: GXandInverted HEX: 4
+CONSTANT: GXnoop HEX: 5
+CONSTANT: GXxor HEX: 6
+CONSTANT: GXor HEX: 7
+CONSTANT: GXnor HEX: 8
+CONSTANT: GXequiv HEX: 9
+CONSTANT: GXinvert HEX: a
+CONSTANT: GXorReverse HEX: b
+CONSTANT: GXcopyInverted HEX: c
+CONSTANT: GXorInverted HEX: d
+CONSTANT: GXnand HEX: e
+CONSTANT: GXset HEX: f
C-STRUCT: XGCValues
{ "int" "function" }
! 8.7 - Transferring Images between Client and Server
-: XYBitmap 0 ; inline
-: XYPixmap 1 ; inline
-: ZPixmap 2 ; inline
-: AllPlanes -1 ; inline
+CONSTANT: XYBitmap 0
+CONSTANT: XYPixmap 1
+CONSTANT: ZPixmap 2
+CONSTANT: AllPlanes -1
C-STRUCT: XImage-funcs
{ "void*" "create_image" }
: ColormapChangeMask ( -- n ) 23 2^ ; inline
: OwnerGrabButtonMask ( -- n ) 24 2^ ; inline
-: KeyPress 2 ; inline
-: KeyRelease 3 ; inline
-: ButtonPress 4 ; inline
-: ButtonRelease 5 ; inline
-: MotionNotify 6 ; inline
-: EnterNotify 7 ; inline
-: LeaveNotify 8 ; inline
-: FocusIn 9 ; inline
-: FocusOut 10 ; inline
-: KeymapNotify 11 ; inline
-: Expose 12 ; inline
-: GraphicsExpose 13 ; inline
-: NoExpose 14 ; inline
-: VisibilityNotify 15 ; inline
-: CreateNotify 16 ; inline
-: DestroyNotify 17 ; inline
-: UnmapNotify 18 ; inline
-: MapNotify 19 ; inline
-: MapRequest 20 ; inline
-: ReparentNotify 21 ; inline
-: ConfigureNotify 22 ; inline
-: ConfigureRequest 23 ; inline
-: GravityNotify 24 ; inline
-: ResizeRequest 25 ; inline
-: CirculateNotify 26 ; inline
-: CirculateRequest 27 ; inline
-: PropertyNotify 28 ; inline
-: SelectionClear 29 ; inline
-: SelectionRequest 30 ; inline
-: SelectionNotify 31 ; inline
-: ColormapNotify 32 ; inline
-: ClientMessage 33 ; inline
-: MappingNotify 34 ; inline
-: LASTEvent 35 ; inline
+CONSTANT: KeyPress 2
+CONSTANT: KeyRelease 3
+CONSTANT: ButtonPress 4
+CONSTANT: ButtonRelease 5
+CONSTANT: MotionNotify 6
+CONSTANT: EnterNotify 7
+CONSTANT: LeaveNotify 8
+CONSTANT: FocusIn 9
+CONSTANT: FocusOut 10
+CONSTANT: KeymapNotify 11
+CONSTANT: Expose 12
+CONSTANT: GraphicsExpose 13
+CONSTANT: NoExpose 14
+CONSTANT: VisibilityNotify 15
+CONSTANT: CreateNotify 16
+CONSTANT: DestroyNotify 17
+CONSTANT: UnmapNotify 18
+CONSTANT: MapNotify 19
+CONSTANT: MapRequest 20
+CONSTANT: ReparentNotify 21
+CONSTANT: ConfigureNotify 22
+CONSTANT: ConfigureRequest 23
+CONSTANT: GravityNotify 24
+CONSTANT: ResizeRequest 25
+CONSTANT: CirculateNotify 26
+CONSTANT: CirculateRequest 27
+CONSTANT: PropertyNotify 28
+CONSTANT: SelectionClear 29
+CONSTANT: SelectionRequest 30
+CONSTANT: SelectionNotify 31
+CONSTANT: ColormapNotify 32
+CONSTANT: ClientMessage 33
+CONSTANT: MappingNotify 34
+CONSTANT: LASTEvent 35
C-STRUCT: XAnyEvent
{ "int" "type" }
! 10.5 Keyboard and Pointer Events
-: Button1 1 ; inline
-: Button2 2 ; inline
-: Button3 3 ; inline
-: Button4 4 ; inline
-: Button5 5 ; inline
+CONSTANT: Button1 1
+CONSTANT: Button2 2
+CONSTANT: Button3 3
+CONSTANT: Button4 4
+CONSTANT: Button5 5
: Button1Mask ( -- n ) 1 8 shift ; inline
: Button2Mask ( -- n ) 1 9 shift ; inline
! 11.3 - Event Queue Management
-: QueuedAlready 0 ; inline
-: QueuedAfterReading 1 ; inline
-: QueuedAfterFlush 2 ; inline
+CONSTANT: QueuedAlready 0
+CONSTANT: QueuedAfterReading 1
+CONSTANT: QueuedAfterFlush 2
FUNCTION: int XEventsQueued ( Display* display, int mode ) ;
FUNCTION: int XPending ( Display* display ) ;
! 12 - Input Device Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: None 0 ; inline
+CONSTANT: None 0
FUNCTION: int XGrabPointer (
Display* display,
! 16.7 Determining the Appropriate Visual Type
-: VisualNoMask HEX: 0 ; inline
-: VisualIDMask HEX: 1 ; inline
-: VisualScreenMask HEX: 2 ; inline
-: VisualDepthMask HEX: 4 ; inline
-: VisualClassMask HEX: 8 ; inline
-: VisualRedMaskMask HEX: 10 ; inline
-: VisualGreenMaskMask HEX: 20 ; inline
-: VisualBlueMaskMask HEX: 40 ; inline
-: VisualColormapSizeMask HEX: 80 ; inline
-: VisualBitsPerRGBMask HEX: 100 ; inline
-: VisualAllMask HEX: 1FF ; inline
+CONSTANT: VisualNoMask HEX: 0
+CONSTANT: VisualIDMask HEX: 1
+CONSTANT: VisualScreenMask HEX: 2
+CONSTANT: VisualDepthMask HEX: 4
+CONSTANT: VisualClassMask HEX: 8
+CONSTANT: VisualRedMaskMask HEX: 10
+CONSTANT: VisualGreenMaskMask HEX: 20
+CONSTANT: VisualBlueMaskMask HEX: 40
+CONSTANT: VisualColormapSizeMask HEX: 80
+CONSTANT: VisualBitsPerRGBMask HEX: 100
+CONSTANT: VisualAllMask HEX: 1FF
C-STRUCT: XVisualInfo
{ "Visual*" "visual" }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: XA_PRIMARY 1 ; inline
-: XA_SECONDARY 2 ; inline
-: XA_ARC 3 ; inline
-: XA_ATOM 4 ; inline
-: XA_BITMAP 5 ; inline
-: XA_CARDINAL 6 ; inline
-: XA_COLORMAP 7 ; inline
-: XA_CURSOR 8 ; inline
-: XA_CUT_BUFFER0 9 ; inline
-: XA_CUT_BUFFER1 10 ; inline
-: XA_CUT_BUFFER2 11 ; inline
-: XA_CUT_BUFFER3 12 ; inline
-: XA_CUT_BUFFER4 13 ; inline
-: XA_CUT_BUFFER5 14 ; inline
-: XA_CUT_BUFFER6 15 ; inline
-: XA_CUT_BUFFER7 16 ; inline
-: XA_DRAWABLE 17 ; inline
-: XA_FONT 18 ; inline
-: XA_INTEGER 19 ; inline
-: XA_PIXMAP 20 ; inline
-: XA_POINT 21 ; inline
-: XA_RECTANGLE 22 ; inline
-: XA_RESOURCE_MANAGER 23 ; inline
-: XA_RGB_COLOR_MAP 24 ; inline
-: XA_RGB_BEST_MAP 25 ; inline
-: XA_RGB_BLUE_MAP 26 ; inline
-: XA_RGB_DEFAULT_MAP 27 ; inline
-: XA_RGB_GRAY_MAP 28 ; inline
-: XA_RGB_GREEN_MAP 29 ; inline
-: XA_RGB_RED_MAP 30 ; inline
-: XA_STRING 31 ; inline
-: XA_VISUALID 32 ; inline
-: XA_WINDOW 33 ; inline
-: XA_WM_COMMAND 34 ; inline
-: XA_WM_HINTS 35 ; inline
-: XA_WM_CLIENT_MACHINE 36 ; inline
-: XA_WM_ICON_NAME 37 ; inline
-: XA_WM_ICON_SIZE 38 ; inline
-: XA_WM_NAME 39 ; inline
-: XA_WM_NORMAL_HINTS 40 ; inline
-: XA_WM_SIZE_HINTS 41 ; inline
-: XA_WM_ZOOM_HINTS 42 ; inline
-: XA_MIN_SPACE 43 ; inline
-: XA_NORM_SPACE 44 ; inline
-: XA_MAX_SPACE 45 ; inline
-: XA_END_SPACE 46 ; inline
-: XA_SUPERSCRIPT_X 47 ; inline
-: XA_SUPERSCRIPT_Y 48 ; inline
-: XA_SUBSCRIPT_X 49 ; inline
-: XA_SUBSCRIPT_Y 50 ; inline
-: XA_UNDERLINE_POSITION 51 ; inline
-: XA_UNDERLINE_THICKNESS 52 ; inline
-: XA_STRIKEOUT_ASCENT 53 ; inline
-: XA_STRIKEOUT_DESCENT 54 ; inline
-: XA_ITALIC_ANGLE 55 ; inline
-: XA_X_HEIGHT 56 ; inline
-: XA_QUAD_WIDTH 57 ; inline
-: XA_WEIGHT 58 ; inline
-: XA_POINT_SIZE 59 ; inline
-: XA_RESOLUTION 60 ; inline
-: XA_COPYRIGHT 61 ; inline
-: XA_NOTICE 62 ; inline
-: XA_FONT_NAME 63 ; inline
-: XA_FAMILY_NAME 64 ; inline
-: XA_FULL_NAME 65 ; inline
-: XA_CAP_HEIGHT 66 ; inline
-: XA_WM_CLASS 67 ; inline
-: XA_WM_TRANSIENT_FOR 68 ; inline
-
-: XA_LAST_PREDEFINED 68 ; inline
+CONSTANT: XA_PRIMARY 1
+CONSTANT: XA_SECONDARY 2
+CONSTANT: XA_ARC 3
+CONSTANT: XA_ATOM 4
+CONSTANT: XA_BITMAP 5
+CONSTANT: XA_CARDINAL 6
+CONSTANT: XA_COLORMAP 7
+CONSTANT: XA_CURSOR 8
+CONSTANT: XA_CUT_BUFFER0 9
+CONSTANT: XA_CUT_BUFFER1 10
+CONSTANT: XA_CUT_BUFFER2 11
+CONSTANT: XA_CUT_BUFFER3 12
+CONSTANT: XA_CUT_BUFFER4 13
+CONSTANT: XA_CUT_BUFFER5 14
+CONSTANT: XA_CUT_BUFFER6 15
+CONSTANT: XA_CUT_BUFFER7 16
+CONSTANT: XA_DRAWABLE 17
+CONSTANT: XA_FONT 18
+CONSTANT: XA_INTEGER 19
+CONSTANT: XA_PIXMAP 20
+CONSTANT: XA_POINT 21
+CONSTANT: XA_RECTANGLE 22
+CONSTANT: XA_RESOURCE_MANAGER 23
+CONSTANT: XA_RGB_COLOR_MAP 24
+CONSTANT: XA_RGB_BEST_MAP 25
+CONSTANT: XA_RGB_BLUE_MAP 26
+CONSTANT: XA_RGB_DEFAULT_MAP 27
+CONSTANT: XA_RGB_GRAY_MAP 28
+CONSTANT: XA_RGB_GREEN_MAP 29
+CONSTANT: XA_RGB_RED_MAP 30
+CONSTANT: XA_STRING 31
+CONSTANT: XA_VISUALID 32
+CONSTANT: XA_WINDOW 33
+CONSTANT: XA_WM_COMMAND 34
+CONSTANT: XA_WM_HINTS 35
+CONSTANT: XA_WM_CLIENT_MACHINE 36
+CONSTANT: XA_WM_ICON_NAME 37
+CONSTANT: XA_WM_ICON_SIZE 38
+CONSTANT: XA_WM_NAME 39
+CONSTANT: XA_WM_NORMAL_HINTS 40
+CONSTANT: XA_WM_SIZE_HINTS 41
+CONSTANT: XA_WM_ZOOM_HINTS 42
+CONSTANT: XA_MIN_SPACE 43
+CONSTANT: XA_NORM_SPACE 44
+CONSTANT: XA_MAX_SPACE 45
+CONSTANT: XA_END_SPACE 46
+CONSTANT: XA_SUPERSCRIPT_X 47
+CONSTANT: XA_SUPERSCRIPT_Y 48
+CONSTANT: XA_SUBSCRIPT_X 49
+CONSTANT: XA_SUBSCRIPT_Y 50
+CONSTANT: XA_UNDERLINE_POSITION 51
+CONSTANT: XA_UNDERLINE_THICKNESS 52
+CONSTANT: XA_STRIKEOUT_ASCENT 53
+CONSTANT: XA_STRIKEOUT_DESCENT 54
+CONSTANT: XA_ITALIC_ANGLE 55
+CONSTANT: XA_X_HEIGHT 56
+CONSTANT: XA_QUAD_WIDTH 57
+CONSTANT: XA_WEIGHT 58
+CONSTANT: XA_POINT_SIZE 59
+CONSTANT: XA_RESOLUTION 60
+CONSTANT: XA_COPYRIGHT 61
+CONSTANT: XA_NOTICE 62
+CONSTANT: XA_FONT_NAME 63
+CONSTANT: XA_FAMILY_NAME 64
+CONSTANT: XA_FULL_NAME 65
+CONSTANT: XA_CAP_HEIGHT 66
+CONSTANT: XA_WM_CLASS 67
+CONSTANT: XA_WM_TRANSIENT_FOR 68
+
+CONSTANT: XA_LAST_PREDEFINED 68
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The rest of the stuff is not from the book.
! !!! INPUT METHODS
-: XIMPreeditArea HEX: 0001 ; inline
-: XIMPreeditCallbacks HEX: 0002 ; inline
-: XIMPreeditPosition HEX: 0004 ; inline
-: XIMPreeditNothing HEX: 0008 ; inline
-: XIMPreeditNone HEX: 0010 ; inline
-: XIMStatusArea HEX: 0100 ; inline
-: XIMStatusCallbacks HEX: 0200 ; inline
-: XIMStatusNothing HEX: 0400 ; inline
-: XIMStatusNone HEX: 0800 ; inline
-
-: XNVaNestedList "XNVaNestedList" ;
-: XNQueryInputStyle "queryInputStyle" ;
-: XNClientWindow "clientWindow" ;
-: XNInputStyle "inputStyle" ;
-: XNFocusWindow "focusWindow" ;
-: XNResourceName "resourceName" ;
-: XNResourceClass "resourceClass" ;
-: XNGeometryCallback "geometryCallback" ;
-: XNDestroyCallback "destroyCallback" ;
-: XNFilterEvents "filterEvents" ;
-: XNPreeditStartCallback "preeditStartCallback" ;
-: XNPreeditDoneCallback "preeditDoneCallback" ;
-: XNPreeditDrawCallback "preeditDrawCallback" ;
-: XNPreeditCaretCallback "preeditCaretCallback" ;
-: XNPreeditStateNotifyCallback "preeditStateNotifyCallback" ;
-: XNPreeditAttributes "preeditAttributes" ;
-: XNStatusStartCallback "statusStartCallback" ;
-: XNStatusDoneCallback "statusDoneCallback" ;
-: XNStatusDrawCallback "statusDrawCallback" ;
-: XNStatusAttributes "statusAttributes" ;
-: XNArea "area" ;
-: XNAreaNeeded "areaNeeded" ;
-: XNSpotLocation "spotLocation" ;
-: XNColormap "colorMap" ;
-: XNStdColormap "stdColorMap" ;
-: XNForeground "foreground" ;
-: XNBackground "background" ;
-: XNBackgroundPixmap "backgroundPixmap" ;
-: XNFontSet "fontSet" ;
-: XNLineSpace "lineSpace" ;
-: XNCursor "cursor" ;
-
-: XNQueryIMValuesList "queryIMValuesList" ;
-: XNQueryICValuesList "queryICValuesList" ;
-: XNVisiblePosition "visiblePosition" ;
-: XNR6PreeditCallback "r6PreeditCallback" ;
-: XNStringConversionCallback "stringConversionCallback" ;
-: XNStringConversion "stringConversion" ;
-: XNResetState "resetState" ;
-: XNHotKey "hotKey" ;
-: XNHotKeyState "hotKeyState" ;
-: XNPreeditState "preeditState" ;
-: XNSeparatorofNestedList "separatorofNestedList" ;
-
-: XBufferOverflow -1 ;
-: XLookupNone 1 ;
-: XLookupChars 2 ;
-: XLookupKeySym 3 ;
-: XLookupBoth 4 ;
+CONSTANT: XIMPreeditArea HEX: 0001
+CONSTANT: XIMPreeditCallbacks HEX: 0002
+CONSTANT: XIMPreeditPosition HEX: 0004
+CONSTANT: XIMPreeditNothing HEX: 0008
+CONSTANT: XIMPreeditNone HEX: 0010
+CONSTANT: XIMStatusArea HEX: 0100
+CONSTANT: XIMStatusCallbacks HEX: 0200
+CONSTANT: XIMStatusNothing HEX: 0400
+CONSTANT: XIMStatusNone HEX: 0800
+
+CONSTANT: XNVaNestedList "XNVaNestedList"
+CONSTANT: XNQueryInputStyle "queryInputStyle"
+CONSTANT: XNClientWindow "clientWindow"
+CONSTANT: XNInputStyle "inputStyle"
+CONSTANT: XNFocusWindow "focusWindow"
+CONSTANT: XNResourceName "resourceName"
+CONSTANT: XNResourceClass "resourceClass"
+CONSTANT: XNGeometryCallback "geometryCallback"
+CONSTANT: XNDestroyCallback "destroyCallback"
+CONSTANT: XNFilterEvents "filterEvents"
+CONSTANT: XNPreeditStartCallback "preeditStartCallback"
+CONSTANT: XNPreeditDoneCallback "preeditDoneCallback"
+CONSTANT: XNPreeditDrawCallback "preeditDrawCallback"
+CONSTANT: XNPreeditCaretCallback "preeditCaretCallback"
+CONSTANT: XNPreeditStateNotifyCallback "preeditStateNotifyCallback"
+CONSTANT: XNPreeditAttributes "preeditAttributes"
+CONSTANT: XNStatusStartCallback "statusStartCallback"
+CONSTANT: XNStatusDoneCallback "statusDoneCallback"
+CONSTANT: XNStatusDrawCallback "statusDrawCallback"
+CONSTANT: XNStatusAttributes "statusAttributes"
+CONSTANT: XNArea "area"
+CONSTANT: XNAreaNeeded "areaNeeded"
+CONSTANT: XNSpotLocation "spotLocation"
+CONSTANT: XNColormap "colorMap"
+CONSTANT: XNStdColormap "stdColorMap"
+CONSTANT: XNForeground "foreground"
+CONSTANT: XNBackground "background"
+CONSTANT: XNBackgroundPixmap "backgroundPixmap"
+CONSTANT: XNFontSet "fontSet"
+CONSTANT: XNLineSpace "lineSpace"
+CONSTANT: XNCursor "cursor"
+
+CONSTANT: XNQueryIMValuesList "queryIMValuesList"
+CONSTANT: XNQueryICValuesList "queryICValuesList"
+CONSTANT: XNVisiblePosition "visiblePosition"
+CONSTANT: XNR6PreeditCallback "r6PreeditCallback"
+CONSTANT: XNStringConversionCallback "stringConversionCallback"
+CONSTANT: XNStringConversion "stringConversion"
+CONSTANT: XNResetState "resetState"
+CONSTANT: XNHotKey "hotKey"
+CONSTANT: XNHotKeyState "hotKeyState"
+CONSTANT: XNPreeditState "preeditState"
+CONSTANT: XNSeparatorofNestedList "separatorofNestedList"
+
+CONSTANT: XBufferOverflow -1
+CONSTANT: XLookupNone 1
+CONSTANT: XLookupChars 2
+CONSTANT: XLookupKeySym 3
+CONSTANT: XLookupBoth 4
FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ;
FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
! !!! category of setlocale
-: LC_ALL 0 ; inline
-: LC_COLLATE 1 ; inline
-: LC_CTYPE 2 ; inline
-: LC_MONETARY 3 ; inline
-: LC_NUMERIC 4 ; inline
-: LC_TIME 5 ; inline
+CONSTANT: LC_ALL 0
+CONSTANT: LC_COLLATE 1
+CONSTANT: LC_CTYPE 2
+CONSTANT: LC_MONETARY 3
+CONSTANT: LC_NUMERIC 4
+CONSTANT: LC_TIME 5
FUNCTION: char* setlocale ( int category, char* name ) ;
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax assocs ;
IN: xml.entities
ABOUT: "xml.entities"
"For entities used in HTML/XHTML, see " { $vocab-link "xml.entities.html" } ;
HELP: entities
+{ $values { "value" assoc } }
{ $description "A hash table from default XML entity names (like " { $snippet "&" } " and " { $snippet "<" } ") to the characters they represent. This is automatically included when parsing any XML document." }
{ $see-also with-entities } ;
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.
: 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
TUPLE: attr-w/< < xml-error-at ;
-: attr-w/< ( value -- * )
+: attr-w/< ( -- * )
\ attr-w/< xml-error-at throw ;
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
--- /dev/null
+vm
+temp
+logs
+.git
+.gitignore
+Makefile
+unmaintained
+build-support
+++ /dev/null
-#include <stdio.h>
-#include <sys/event.h>
-
-#if defined(__FreeBSD__)
- #define BSD
- #define FREEBSD
- #define UNIX
-#endif
-
-#if defined(__NetBSD__)
- #define BSD
- #define NETBSD
- #define UNIX
-#endif
-
-#if defined(__OpenBSD__)
- #define BSD
- #define OPENBSD
- #define UNIX
-#endif
-
-#if defined(__APPLE__)
- #define BSD
- #define MACOSX
- #define UNIX
-#endif
-
-#if defined(linux)
- #define LINUX
- #define UNIX
-#endif
-
-#if defined(__amd64__) || defined(__x86_64__)
- #define BIT64
-#else
- #define BIT32
-#endif
-
-#if defined(UNIX)
- #include <sys/types.h>
- #include <sys/stat.h>
- #include <sys/socket.h>
- #include <sys/errno.h>
- #include <sys/mman.h>
- #include <sys/syslimits.h>
- #include <fcntl.h>
- #include <unistd.h>
-#endif
-
-#define BL printf(" ");
-#define QUOT printf("\"");
-#define NL printf("\n");
-#define LB printf("{"); BL
-#define RB BL printf("}");
-#define SEMI printf(";");
-#define grovel(t) printf("TYPEDEF: "); printf("%d", sizeof(t)); BL printf(#t); NL
-#define grovel2impl(t,n) BL BL BL BL LB QUOT printf(#t); QUOT BL QUOT printf((n)); QUOT RB
-#define grovel2(t,n) grovel2impl(t,n) NL
-#define grovel2end(t,n) grovel2impl(t,n) BL SEMI NL
-#define header(os) printf("vvv %s vvv", (os)); NL
-#define footer(os) printf("^^^ %s ^^^", (os)); NL
-#define header2(os,struct) printf("vvv %s %s vvv", (os), (struct)); NL
-#define footer2(os,struct) printf("^^^ %s %s ^^^", (os), (struct)); NL
-#define struct(n) printf("C-STRUCT: %s\n", (n));
-#define constant(n) printf("#define "); printf(#n); printf(" %d (HEX: %04x)", (n), (n)); NL
-
-void openbsd_types()
-{
- header2("openbsd", "types");
- grovel(dev_t);
- grovel(gid_t);
- grovel(ino_t);
- grovel(int32_t);
- grovel(int64_t);
- grovel(mode_t);
- grovel(nlink_t);
- grovel(off_t);
- grovel(struct timespec);
- grovel(uid_t);
- footer2("openbsd", "types");
-}
-
-void openbsd_stat()
-{
- header2("openbsd", "stat");
- struct("stat");
- grovel2(dev_t, "st_dev");
- grovel2(ino_t, "st_ino");
- grovel2(mode_t, "st_mode");
- grovel2(nlink_t, "st_nlink");
- grovel2(uid_t, "st_uid");
- grovel2(gid_t, "st_gid");
- grovel2(dev_t, "st_rdev");
- grovel2(int32_t, "st_lspare0");
- grovel2(struct timespec, "st_atim");
- grovel2(struct timespec, "st_mtim");
- grovel2(struct timespec, "st_ctim");
- grovel2(off_t, "st_size");
- grovel2(int64_t, "st_blocks");
- grovel2(u_int32_t, "st_blksize");
- grovel2(u_int32_t, "st_flags");
- grovel2(u_int32_t, "st_gen");
- grovel2(int32_t, "st_lspare1");
- grovel2(struct timespec, "st_birthtimespec");
- grovel2(int64_t, "st_qspare1");
- grovel2end(int64_t, "st_qspare2");
- footer2("openbsd", "stat");
-}
-
-void unix_types()
-{
- grovel(dev_t);
- grovel(gid_t);
- grovel(ino_t);
- grovel(int32_t);
- grovel(int64_t);
- grovel(mode_t);
- grovel(nlink_t);
- grovel(off_t);
- grovel(struct timespec);
- grovel(struct stat);
- grovel(time_t);
- grovel(uid_t);
-}
-
-void unix_constants()
-{
- constant(O_RDONLY);
- constant(O_WRONLY);
- constant(O_RDWR);
- constant(O_APPEND);
- constant(O_CREAT);
- constant(O_TRUNC);
- constant(O_EXCL);
- constant(FD_SETSIZE);
- constant(SOL_SOCKET);
- constant(SO_REUSEADDR);
- constant(SO_OOBINLINE);
- constant(SO_SNDTIMEO);
- constant(SO_RCVTIMEO);
- constant(F_SETFL);
- constant(O_NONBLOCK);
- constant(EINTR);
- constant(EAGAIN);
- constant(EINPROGRESS);
- constant(PROT_READ);
- constant(PROT_WRITE);
- constant(MAP_FILE);
- constant(MAP_SHARED);
- constant(PATH_MAX);
- grovel(pid_t);
-
-}
-
-int main() {
-#ifdef FREEBSD
- grovel(blkcnt_t);
- grovel(blksize_t);
- grovel(fflags_t);
-#endif
-
-#ifdef OPENBSD
- openbsd_stat();
- openbsd_types();
-#endif
- grovel(blkcnt_t);
- grovel(blksize_t);
- //grovel(fflags_t);
- grovel(ssize_t);
-
- grovel(size_t);
- grovel(struct kevent);
-#ifdef UNIX
- unix_types();
- unix_constants();
-#endif
-
- return 0;
-}
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection key? }
{ $subsection at }
+{ $subsection ?at }
{ $subsection assoc-empty? }
{ $subsection keys }
{ $subsection values }
{ $values { "key" object } { "assoc" assoc } { "?" "a boolean" } }
{ $description "Tests if an assoc contains a key." } ;
-{ at at* key? } related-words
+{ at at* key? ?at } related-words
HELP: at
{ $values { "key" "an object" } { "assoc" assoc } { "value/f" "the value associated to the key, or " { $link f } " if the key is not present in the assoc" } }
{ $description "Looks up the value associated with a key. This word makes no distinction between a missing value and a value set to " { $link f } "; if the difference is important, use " { $link at* } "." } ;
+HELP: ?at
+{ $values { "key" "an object" } { "assoc" assoc } { "value/key" "the value associated to the key, or the key if the key is not present in the assoc" } { "?" "a boolean" } }
+{ $description "Looks up the value associated with a key. If the key was not present, an error can be thrown without extra stack shuffling. This word handles assocs that store " { $link f } "." } ;
+
HELP: assoc-each
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- )" } } }
{ $description "Applies a quotation to each entry in the assoc." }
{ "c" [ 3 ] }
{ "d" [ 4 ] }
} [ nip first even? ] assoc-partition
-] unit-test
\ No newline at end of file
+] unit-test
+
+[ 1 f ] [ 1 H{ } ?at ] unit-test
+[ 2 t ] [ 1 H{ { 1 2 } } ?at ] unit-test
M: assoc assoc-like drop ;
+: ?at ( key assoc -- value/key ? )
+ dupd at* [ [ nip ] [ drop ] if ] keep ; inline
+
<PRIVATE
: (assoc-each) ( assoc quot -- seq quot' )
[ first = ] with find swap ; inline
: substituter ( assoc -- quot )
- [ dupd at* [ nip ] [ drop ] if ] curry ; inline
+ [ ?at drop ] curry ; inline
: with-assoc ( assoc quot: ( value key -- assoc ) -- quot: ( key value -- ) )
curry [ swap ] prepose ; inline
at* drop ; inline
: at-default ( key assoc -- value/key )
- 2dup at* [ 2nip ] [ 2drop ] if ; inline
+ ?at drop ; inline
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ dup assoc-size ] dip new-assoc
[ [ 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
! Copyright (C) 2006 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences sequences.private namespaces
-words io io.binary io.files io.streams.string quotations
+words io io.binary io.files quotations
definitions checksums ;
IN: checksums.crc32
-: crc32-polynomial HEX: edb88320 ; inline
+CONSTANT: crc32-polynomial HEX: edb88320
-: crc32-table V{ } ; inline
+CONSTANT: crc32-table V{ }
256 [
8 [
ARTICLE: "slot-class-coercion" "Coercive slot declarations"
"If the class of a slot is declared to be one of " { $link fixnum } " or " { $link float } ", then rather than testing values with the class predicate, writer words coerce values to the relevant type with " { $link >fixnum } " or " { $link >float } ". This may still result in error, but permits a wider range of values than a class predicate test. It also results in a possible loss of precision; for example, storing a large integer into a " { $link fixnum } " slot will silently overflow and discard high bits, and storing a ratio into a " { $link float } " slot may lose precision if the ratio is one which cannot be represented exactly with floating-point."
$nl
-"This feature is mostly intended as an optimization for low-level code designed to avoid integer overflow, or where floating point precision is sufficient. Most code needs to work transparently with large integers, and thus hsould avoid the coercion behavior by using " { $link integer } " and " { $link real } " in place of " { $link fixnum } " and " { $link float } "." ;
+"This feature is mostly intended as an optimization for low-level code designed to avoid integer overflow, or where floating point precision is sufficient. Most code needs to work transparently with large integers, and thus should avoid the coercion behavior by using " { $link integer } " and " { $link real } " in place of " { $link fixnum } " and " { $link float } "." ;
ARTICLE: "tuple-declarations" "Tuple slot declarations"
"The slot specifier syntax of the " { $link POSTPONE: TUPLE: } " parsing word understands the following slot attributes:"
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
-: case-const-1 1 ;
-: case-const-2 2 ; inline
+CONSTANT: case-const-1 1
+CONSTANT: case-const-2 2
! Compiled
: case-test-4 ( obj -- str )
quotations words.symbol ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"The compiler saves " { $link "inference-errors" } " in a global variable:"
-{ $subsection compiler-errors }
-"These notifications can be viewed later:"
+"After loading a vocabulary, you might see messages like:"
+{ $code
+ ":errors - print 2 compiler errors."
+ ":warnings - print 50 compiler warnings."
+}
+"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
+$nl
+"The precise warning and error conditions are documented in " { $link "inference-errors" } "."
+$nl
+"Words to view warnings and errors:"
{ $subsection :errors }
{ $subsection :warnings }
{ $subsection :linkage }
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." } ;
] [ ] cleanup
] with-scope ; inline
-: compile-call ( quot -- )
- [ define-temp ] with-compilation-unit execute ;
-
: default-recompile-hook ( words -- alist )
[ f ] { } map>assoc ;
PRIVATE>
-: continue-with ( obj continuation -- )
+: continue-with ( obj continuation -- * )
[ (continue-with) ] 2 (throw) ;
-: continue ( continuation -- )
+: continue ( continuation -- * )
f swap continue-with ;
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 )
C: <restart> restart
-: restart ( restart -- )
+: restart ( restart -- * )
[ obj>> ] [ continuation>> ] bi continue-with ;
M: object compute-restarts drop { } ;
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 <effect> ;
convert-hi-tag-methods
<lo-tag-dispatch-engine> ;
+: mangle-method ( method -- quot )
+ 1quotation generic get extra-values \ drop <repetition>
+ 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 <repetition> ] bi*
- prepend [ ] like ;
-
: <standard-engine> ( word -- engine )
object bootstrap-word assumed set {
[ generic set ]
[ V{ } clone "engines" set-word-prop ]
[
"methods" word-prop
- [ generic get mangle-method ] assoc-map
+ [ mangle-method ] assoc-map
[ find-default default set ]
[ <big-dispatch-engine> ]
bi
-USING: help.markup help.syntax io quotations ;
+USING: help.markup help.syntax io quotations math ;
IN: io.encodings
HELP: <encoder>
{ $description "Creates a new encoder with the given encoding descriptor and calls the quotation using this encoder. The original encoder object is restored after the quotation returns and the stream is kept open for future output operations." } ;
HELP: replacement-char
+{ $values
+ { "value" integer }
+}
{ $description "A code point that replaces input that could not be decoded. The presence of this character in the decoded data usually signifies an error." } ;
ARTICLE: "encodings-descriptors" "Encoding descriptors"
GENERIC: <decoder> ( stream encoding -- newstream )
-: replacement-char HEX: fffd ; inline
+CONSTANT: replacement-char HEX: fffd
TUPLE: decoder stream code cr ;
-USING: help.markup help.syntax io.backend io.files strings ;
+USING: help.markup help.syntax io.backend io.files strings
+sequences ;
IN: io.pathnames
HELP: path-separator?
{ $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
} ;
+HELP: path-components
+{ $values { "path" "a pathnames string" } { "seq" sequence } }
+{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ;
+
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
+HELP: canonicalize-path
+{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
+{ $description "Returns an canonical name for a path. The canonical name is an absolute path containing no symlinks." } ;
+
HELP: <pathname>
{ $values { "string" "a pathname string" } { "pathname" pathname } }
{ $description "Creates a new " { $link pathname } "." } ;
{ $subsection POSTPONE: P" }
"Pathname manipulation:"
{ $subsection normalize-path }
+{ $subsection canonicalize-path }
{ $subsection parent-directory }
{ $subsection file-name }
{ $subsection last-path-separator }
+{ $subsection path-components }
+{ $subsection prepend-path }
{ $subsection append-path }
"Pathname presentations:"
{ $subsection pathname }
] with-scope
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
+
+! Regression test for bug in file-extension
+[ f ] [ "/funny.directory/file-with-no-extension" file-extension ] unit-test
+[ "" ] [ "/funny.directory/file-with-no-extension." file-extension ] unit-test
] unless ;
: file-extension ( filename -- extension )
- "." split1-last nip ;
+ file-name "." split1-last nip ;
+
+: path-components ( path -- seq )
+ normalize-path path-separator split harvest ;
+
+HOOK: canonicalize-path os ( path -- path' )
+
+M: object canonicalize-path normalize-path ;
: resource-path ( path -- newpath )
"resource-path" get prepend-path ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences io kernel accessors math math.order ;
+IN: io.streams.sequence
+
+SLOT: underlying
+SLOT: i
+
+: >sequence-stream< ( stream -- i underlying )
+ [ i>> ] [ underlying>> ] bi ; inline
+
+: next ( stream -- )
+ [ 1+ ] change-i drop ;
+
+: sequence-read1 ( stream -- elt/f )
+ [ >sequence-stream< ?nth ]
+ [ next ] bi ; inline
+
+: add-length ( n stream -- i+n )
+ [ i>> + ] [ underlying>> length ] bi min ;
+
+: (sequence-read) ( n stream -- seq/f )
+ [ add-length ] keep
+ [ [ swap dup ] change-i drop ]
+ [ underlying>> ] bi
+ subseq ; inline
+
+: sequence-read ( n stream -- seq/f )
+ dup >sequence-stream< bounds-check?
+ [ (sequence-read) ] [ 2drop f ] if ; inline
+
+: find-sep ( seps stream -- sep/f n )
+ swap [ >sequence-stream< ] dip
+ [ memq? ] curry find-from swap ; inline
+
+: sequence-read-until ( separators stream -- seq sep/f )
+ [ find-sep ] keep
+ [ sequence-read ] [ next ] bi swap ; inline
[ "xyzzy" ] [ [ "xyzzy" write ] with-string-writer ] unit-test
-[ "a" ] [ 1 SBUF" cba" stream-read ] unit-test
-[ "ab" ] [ 2 SBUF" cba" stream-read ] unit-test
-[ "abc" ] [ 3 SBUF" cba" stream-read ] unit-test
-[ "abc" ] [ 4 SBUF" cba" stream-read ] unit-test
+[ "a" ] [ 1 "abc" <string-reader> stream-read ] unit-test
+[ "ab" ] [ 2 "abc" <string-reader> stream-read ] unit-test
+[ "abc" ] [ 3 "abc" <string-reader> stream-read ] unit-test
+[ "abc" ] [ 4 "abc" <string-reader> stream-read ] unit-test
[ "abc" f ] [
- 3 SBUF" cba" [ stream-read ] keep stream-read1
+ 3 "abc" <string-reader> [ stream-read ] keep stream-read1
] unit-test
[
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math namespaces sequences sbufs
-strings generic splitting continuations destructors
-io.streams.plain io.encodings math.order growable ;
+strings generic splitting continuations destructors sequences.private
+io.streams.plain io.encodings math.order growable io.streams.sequence ;
IN: io.streams.string
<PRIVATE
-: harden-as ( seq growble-exemplar -- newseq )
- underlying>> like ;
-
-: growable-read-until ( growable n -- str )
- >fixnum dupd tail-slice swap harden-as dup reverse-here ;
-
SINGLETON: null-encoding
M: null-encoding decode-char drop stream-read1 ;
<string-writer> swap [ output-stream get ] compose with-output-stream*
>string ; inline
-M: growable stream-read1 [ f ] [ pop ] if-empty ;
-
-: find-last-sep ( seq seps -- n )
- swap [ memq? ] curry find-last drop ;
-
-M: growable stream-read-until
- [ find-last-sep ] keep over [
- [ swap 1+ growable-read-until ] 2keep [ nth ] 2keep
- set-length
- ] [
- [ swap drop 0 growable-read-until f like f ] keep
- delete-all
- ] if ;
+! New implementation
-M: growable stream-read
- [
- drop f
- ] [
- [ length swap - 0 max ] keep
- [ swap growable-read-until ] 2keep
- set-length
- ] if-empty ;
+TUPLE: string-reader { underlying string read-only } { i array-capacity } ;
-M: growable stream-read-partial
- stream-read ;
+M: string-reader stream-read-partial stream-read ;
+M: string-reader stream-read sequence-read ;
+M: string-reader stream-read1 sequence-read1 ;
+M: string-reader stream-read-until sequence-read-until ;
+M: string-reader dispose drop ;
: <string-reader> ( str -- stream )
- >sbuf dup reverse-here null-encoding <decoder> ;
+ 0 string-reader boa null-encoding <decoder> ;
: with-string-reader ( str quot -- )
[ <string-reader> ] dip with-input-stream ; inline
{ $description "Clears the data stack." } ;
HELP: build
+{ $values { "n" integer } }
{ $description "The current build number. Factor increments this number whenever a new boot image is created." } ;
HELP: hashcode*
[ f ] [ BIN: -1101 >bignum 3 bit? ] unit-test
[ t ] [ BIN: -1101 >bignum 4 bit? ] unit-test
+[ t ] [ 1067811677921310779 >bignum 59 bit? ] unit-test
+
[ 2 ] [ 0 next-power-of-2 ] unit-test
[ 2 ] [ 1 next-power-of-2 ] unit-test
[ 2 ] [ 2 next-power-of-2 ] unit-test
HELP: byte-array>bignum
{ $values { "byte-array" byte-array } { "n" integer } }
-{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link >le } " or " { $link >be } " instead." } ;
+{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link le> } " or " { $link be> } " instead." } ;
ARTICLE: "division-by-zero" "Division by zero"
"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
{ $subsection "vocabs.roots" }
"Vocabulary names map directly to source files. A vocabulary named " { $snippet "foo.bar" } " must be defined in a " { $snippet "bar" } " directory nested inside a " { $snippet "foo" } " directory of a vocabulary root. Any level of vocabulary nesting is permitted."
$nl
-"The vocabulary directory - " { $snippet "bar" } " in our example - can contain the following files; the first is required while the rest are optional:"
+"The vocabulary directory - " { $snippet "bar" } " in our example - contains a source file:"
+{ $list
+ { { $snippet "foo/bar/bar.factor" } " - the source file, must define words in the " { $snippet "foo.bar" } " vocabulary with an " { $snippet "IN: foo.bar" } " form" }
+}
+"Two other Factor source files, storing documentation and tests, respectively, are optional:"
{ $list
- { { $snippet "foo/bar/bar.factor" } " - the source file, defines words in the " { $snippet "foo.bar" } " vocabulary" }
{ { $snippet "foo/bar/bar-docs.factor" } " - documentation, see " { $link "writing-help" } }
{ { $snippet "foo/bar/bar-tests.factor" } " - unit tests, see " { $link "tools.test" } }
+}
+"Finally, three text files can contain meta-data:"
+{ $list
+ { { $snippet "foo/bar/authors.txt" } " - a series of lines, with one author name per line. These are listed under " { $link "vocab-authors" } }
{ { $snippet "foo/bar/summary.txt" } " - a one-line description" }
- { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary" }
+ { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can re-use" }
}
"While " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " load vocabularies which have not been loaded before adding them to the search path, it is also possible to load a vocabulary without adding it to the search path:"
{ $subsection require }
{ $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 } "."
} ;
SYMBOL: visited
-: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
+CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" }
: (redefined) ( word -- )
dup visited get key? [ drop ] [
: gensym ( -- word )
"( gensym )" f <word> ;
-: 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
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 )
-! Copyright (C) 2008 Your name.
+! Copyright (C) 2008 Jeff Bigot.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.markup help.syntax kernel sequences ;
IN: adsoda.combinators
USING: accessors arrays combinators definitions generalizations
help help.markup help.topics kernel sequences sorting vocabs
-words ;
+words combinators.smart ;
IN: annotations
<PRIVATE
: comment-usage.-word ( base -- word ) "s." append "annotations" lookup ;
PRIVATE>
+: $annotation ( element -- )
+ first
+ [ "!" " your comment here" surround 1array $syntax ]
+ [ [ "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 3array $description ]
+ [ ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 1array $code ]
+ tri ;
+
+: <$annotation> ( word -- element )
+ \ $annotation swap 2array 1array ;
+
+: $annotation-usage. ( element -- )
+ first
+ [ "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 3array $description ;
+
+: <$annotation-usage.> ( word -- element )
+ \ $annotation-usage. swap 2array 1array ;
+
+: $annotation-usage ( element -- )
+ first [
+ [ "Returns a list of words, help articles, and vocabularies that contain " ] dip
+ [
+ comment-word <$link>
+ " annotations. For a more user-friendly display, use the "
+ ] [
+ comment-usage.-word <$link>
+ " word."
+ ] bi
+ ] output>array $description ;
+
+: <$annotation-usage> ( word -- element )
+ [ { $values { "usages" sequence } } ] dip
+ \ $annotation-usage swap 2array
+ 2array ;
+
"Code annotations"
{
"The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism."
annotation-tags [
{
- [ [ \ $syntax ] dip "!" " your comment here" surround 2array ]
- [ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ]
- [ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ]
- [ comment-word set-word-help ]
-
- [ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ]
- [ comment-usage.-word set-word-help ]
-
- [ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ]
- [ comment-usage-word set-word-help ]
-
+ [ [ <$annotation> ] [ comment-word set-word-help ] bi ]
+ [ [ <$annotation-usage> ] [ comment-usage-word set-word-help ] bi ]
+ [ [ <$annotation-usage.> ] [ comment-usage.-word set-word-help ] bi ]
[ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ]
} cleave
] each
IN: asn1.ldap
-: SearchScope_BaseObject 0 ; inline
-: SearchScope_SingleLevel 1 ; inline
-: SearchScope_WholeSubtree 2 ; inline
+CONSTANT: SearchScope_BaseObject 0
+CONSTANT: SearchScope_SingleLevel 1
+CONSTANT: SearchScope_WholeSubtree 2
: asn-syntax ( -- hashtable )
H{
! 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 ;
] 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
M: f item-check drop 0 ;
-: min-depth 4 ; inline
+CONSTANT: min-depth 4
: stretch-tree ( max-depth -- )
1 + 0 over bottom-up-tree item-check
byte-arrays specialized-arrays.double ;
IN: benchmark.fasta
-: IM 139968 ; inline
-: IA 3877 ; inline
-: IC 29573 ; inline
-: initial-seed 42 ; inline
-: line-length 60 ; inline
-
-USE: math.private
+CONSTANT: IM 139968
+CONSTANT: IA 3877
+CONSTANT: IC 29573
+CONSTANT: initial-seed 42
+CONSTANT: line-length 60
: random ( seed -- n seed )
>float IA * IC + IM mod [ IM /f ] keep ; inline
HINTS: random fixnum ;
-: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA" ; inline
+CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"
-: IUB
+CONSTANT: IUB
{
{ CHAR: a 0.27 }
{ CHAR: c 0.12 }
{ 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
: scale-rgb ( rgba -- n )
[ red>> scale ] [ green>> scale ] [ blue>> scale ] tri 3byte-array ;
-: sat 0.85 ; inline
-: val 0.85 ; inline
+CONSTANT: sat 0.85
+CONSTANT: val 0.85
: <color-map> ( nb-cols -- map )
dup [
IN: benchmark.mandel.params
-: max-color 360 ; inline
-: zoom-fact 0.8 ; inline
-: width 640 ; inline
-: height 480 ; inline
-: max-iterations 40 ; inline
-: center -0.65 ; inline
+CONSTANT: max-color 360
+CONSTANT: zoom-fact 0.8
+CONSTANT: width 640
+CONSTANT: height 480
+CONSTANT: max-iterations 40
+CONSTANT: center -0.65
IN: benchmark.nbody
: solar-mass ( -- x ) 4 pi sq * ; inline
-: days-per-year 365.24 ; inline
+CONSTANT: days-per-year 365.24
TUPLE: body
{ location double-array }
IN: benchmark.raytracer
! parameters
-: light
- #! Normalized { -1 -3 2 }.
+
+! Normalized { -1 -3 2 }.
+CONSTANT: light
double-array{
-0.2672612419124244
-0.8017837257372732
0.5345224838248488
- } ; inline
+ }
-: oversampling 4 ; inline
+CONSTANT: oversampling 4
-: levels 3 ; inline
+CONSTANT: levels 3
-: size 200 ; inline
+CONSTANT: size 200
-: delta 1.4901161193847656E-8 ; inline
+CONSTANT: delta 1.4901161193847656E-8
TUPLE: ray { orig double-array read-only } { dir double-array read-only } ;
M: group intersect-scene ( hit ray group -- hit )
[ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
-: initial-hit T{ hit f double-array{ 0.0 0.0 0.0 } 1/0. } ; inline
+CONSTANT: initial-hit T{ hit f double-array{ 0.0 0.0 0.0 } 1/0. }
: initial-intersect ( ray scene -- hit )
[ initial-hit ] 2dip intersect-scene ; inline
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 <inet4> ;
! http://cairographics.org/samples/text/
-USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
- ui.gadgets opengl.gl accessors ;
+USING: cairo.ffi math math.constants byte-arrays kernel ui
+ui.render combinators ui.gadgets opengl.gl accessors
+namespaces opengl ;
IN: cairo-demo
-
: make-image-array ( -- array )
- 384 256 4 * * <byte-array> ;
+ 384 256 4 * * <byte-array> ;
: convert-array-to-surface ( array -- cairo_surface_t )
- CAIRO_FORMAT_ARGB32 384 256 over 4 *
- cairo_image_surface_create_for_data ;
-
+ CAIRO_FORMAT_ARGB32 384 256 over 4 *
+ cairo_image_surface_create_for_data ;
TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
M: cairo-demo-gadget draw-gadget* ( gadget -- )
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- [ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip
- image-array>> glDrawPixels ;
+ origin get [
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ [ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip
+ image-array>> glDrawPixels
+ ] with-translation ;
: create-surface ( gadget -- cairo_surface_t )
make-image-array [ swap (>>image-array) ] keep
convert-array-to-surface ;
: init-cairo ( gadget -- cairo_t )
- create-surface cairo_create ;
+ create-surface cairo_create ;
+
+M: cairo-demo-gadget pref-dim* drop { 384 256 } ;
+
+ERROR: no-cairo-t ;
-M: cairo-demo-gadget pref-dim* drop { 384 256 0 } ;
+<PRIVATE
: draw-hello-world ( gadget -- )
- cairo-t>>
- dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face
- dup 90.0 cairo_set_font_size
- dup 10.0 135.0 cairo_move_to
- dup "Hello" cairo_show_text
- dup 70.0 165.0 cairo_move_to
- dup "World" cairo_text_path
- dup 0.5 0.5 1 cairo_set_source_rgb
- dup cairo_fill_preserve
- dup 0 0 0 cairo_set_source_rgb
- dup 2.56 cairo_set_line_width
- dup cairo_stroke
- dup 1 0.2 0.2 0.6 cairo_set_source_rgba
- dup 10.0 135.0 5.12 0 pi 2 * cairo_arc
- dup cairo_close_path
- dup 70.0 165.0 5.12 0 pi 2 * cairo_arc
- cairo_fill ;
+ cairo-t>> [ no-cairo-t ] unless*
+ {
+ [
+ "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
+ cairo_select_font_face
+ ]
+ [ 90.0 cairo_set_font_size ]
+ [ 10.0 135.0 cairo_move_to ]
+ [ "Hello" cairo_show_text ]
+ [ 70.0 165.0 cairo_move_to ]
+ [ "World" cairo_text_path ]
+ [ 0.5 0.5 1 cairo_set_source_rgb ]
+ [ cairo_fill_preserve ]
+ [ 0 0 0 cairo_set_source_rgb ]
+ [ 2.56 cairo_set_line_width ]
+ [ cairo_stroke ]
+ [ 1 0.2 0.2 0.6 cairo_set_source_rgba ]
+ [ 10.0 135.0 5.12 0 pi 2 * cairo_arc ]
+ [ cairo_close_path ]
+ [ 70.0 165.0 5.12 0 pi 2 * cairo_arc ]
+ [ cairo_fill ]
+ } cleave ;
+
+PRIVATE>
M: cairo-demo-gadget graft* ( gadget -- )
- dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
+ dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
M: cairo-demo-gadget ungraft* ( gadget -- )
- cairo-t>> cairo_destroy ;
+ cairo-t>> cairo_destroy ;
: <cairo-demo-gadget> ( -- gadget )
- cairo-demo-gadget new-gadget ;
+ cairo-demo-gadget new-gadget ;
: run ( -- )
- [
+ [
<cairo-demo-gadget> "Hello World from Factor!" open-window
- ] with-ui ;
+ ] with-ui ;
MAIN: run
locals ;
IN: crypto.aes
-: AES_BLOCK_SIZE 16 ; inline
+CONSTANT: AES_BLOCK_SIZE 16
: sbox ( -- array )
{
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel base64 checksums.md5 sequences checksums
-locals prettyprint math math.bitwise grouping io combinators
+locals prettyprint math math.bits grouping io combinators
fry make combinators.short-circuit math.functions splitting ;
IN: crypto.passwd-md5
password length
[ 16 / ceiling swap <repetition> concat ] keep
head-slice append
- password [ length ] [ first ] bi
- '[ [ CHAR: \0 _ ? , ] each-bit ] "" make append
+ password [ length make-bits ] [ first ] bi
+ '[ CHAR: \0 _ ? ] "" map-as append
md5 checksum-bytes ] |
1000 [
"" swap
<PRIVATE
-: public-key 65537 ; inline
+CONSTANT: public-key 65537
: rsa-primes ( numbits -- p q )
2/ 2 unique-primes first2 ;
SYMBOL: curses-windows
SYMBOL: current-window
-: ERR -1 ; inline
-: FALSE 0 ; inline
-: TRUE 1 ; inline
+CONSTANT: ERR -1
+CONSTANT: FALSE 0
+CONSTANT: TRUE 1
: >BOOLEAN ( n -- TRUE/FALSE ) >boolean TRUE FALSE ? ; inline
ERROR: duplicate-window window ;
TYPEDEF: short NCURSES_SIZE_T
TYPEDEF: ushort wchar_t
-: CCHARW_MAX 5 ; inline
+CONSTANT: CCHARW_MAX 5
C-STRUCT: cchar_t
{ "attr_t" "attr" }
+++ /dev/null
-! Copyright (C) 2008 Your name.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test fuel ;
-IN: fuel.tests
: fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ;
+: fuel-word-synopsis ( word usings -- ) (fuel-word-synopsis) fuel-eval-set-result ;
+
: fuel-vocab-summary ( name -- )
(fuel-vocab-summary) fuel-eval-set-result ;
: (fuel-word-help) ( name -- elem )
fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ;
+: (fuel-word-synopsis) ( word usings -- str/f )
+ [
+ [ vocab ] filter interactive-vocabs [ append ] change
+ fuel-find-word [ synopsis ] [ f ] if*
+ ] with-scope ;
+
: (fuel-word-see) ( word -- elem )
[ name>> \ article swap ]
[ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
compiler.cfg.optimizer fry ;
IN: galois-talk
-: galois-slides
+CONSTANT: galois-slides
{
{ $slide "Factor!"
{ $url "http://factorcode.org" }
"Factor has many cool things that I didn't talk about"
"Questions?"
}
-} ;
+}
: galois-talk ( -- ) galois-slides slides-window ;
succeeded-quot call
] failed-quot if ; 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
- } ; inline
+ }
: >axis ( long -- float )
32767 - 32767.0 /f ;
[ &CFRelease NSFastEnumeration>vector ] [ f ] if*
] with-destructors ;
-: game-devices-matching-seq
+CONSTANT: game-devices-matching-seq
{
H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
- } ; inline
-
-: buttons-matching-hash
- H{ { "UsagePage" 9 } { "Type" 2 } } ; inline
-: keys-matching-hash
- H{ { "UsagePage" 7 } { "Type" 2 } } ; inline
-: x-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } } ; inline
-: y-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } } ; inline
-: z-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } } ; inline
-: rx-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } } ; inline
-: ry-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } } ; inline
-: rz-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } ; inline
-: slider-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } ; inline
-: hat-switch-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } ; inline
+ }
+
+CONSTANT: buttons-matching-hash
+ H{ { "UsagePage" 9 } { "Type" 2 } }
+CONSTANT: keys-matching-hash
+ H{ { "UsagePage" 7 } { "Type" 2 } }
+CONSTANT: x-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } }
+CONSTANT: y-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } }
+CONSTANT: z-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } }
+CONSTANT: rx-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } }
+CONSTANT: ry-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } }
+CONSTANT: rz-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
+CONSTANT: slider-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
+CONSTANT: hat-switch-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
: device-elements-matching ( device matching-hash -- vector )
[
: 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 ;
IN: game-input.scancodes
-: key-undefined HEX: 0000 ; inline
-: key-error-roll-over HEX: 0001 ; inline
-: key-error-post-fail HEX: 0002 ; inline
-: key-error-undefined HEX: 0003 ; inline
-: key-a HEX: 0004 ; inline
-: key-b HEX: 0005 ; inline
-: key-c HEX: 0006 ; inline
-: key-d HEX: 0007 ; inline
-: key-e HEX: 0008 ; inline
-: key-f HEX: 0009 ; inline
-: key-g HEX: 000a ; inline
-: key-h HEX: 000b ; inline
-: key-i HEX: 000c ; inline
-: key-j HEX: 000d ; inline
-: key-k HEX: 000e ; inline
-: key-l HEX: 000f ; inline
-: key-m HEX: 0010 ; inline
-: key-n HEX: 0011 ; inline
-: key-o HEX: 0012 ; inline
-: key-p HEX: 0013 ; inline
-: key-q HEX: 0014 ; inline
-: key-r HEX: 0015 ; inline
-: key-s HEX: 0016 ; inline
-: key-t HEX: 0017 ; inline
-: key-u HEX: 0018 ; inline
-: key-v HEX: 0019 ; inline
-: key-w HEX: 001a ; inline
-: key-x HEX: 001b ; inline
-: key-y HEX: 001c ; inline
-: key-z HEX: 001d ; inline
-: key-1 HEX: 001e ; inline
-: key-2 HEX: 001f ; inline
-: key-3 HEX: 0020 ; inline
-: key-4 HEX: 0021 ; inline
-: key-5 HEX: 0022 ; inline
-: key-6 HEX: 0023 ; inline
-: key-7 HEX: 0024 ; inline
-: key-8 HEX: 0025 ; inline
-: key-9 HEX: 0026 ; inline
-: key-0 HEX: 0027 ; inline
-: key-return HEX: 0028 ; inline
-: key-escape HEX: 0029 ; inline
-: key-backspace HEX: 002a ; inline
-: key-tab HEX: 002b ; inline
-: key-space HEX: 002c ; inline
-: key-- HEX: 002d ; inline
-: key-= HEX: 002e ; inline
-: key-[ HEX: 002f ; inline
-: key-] HEX: 0030 ; inline
-: key-\ HEX: 0031 ; inline
-: key-#-non-us HEX: 0032 ; inline
-: key-; HEX: 0033 ; inline
-: key-' HEX: 0034 ; inline
-: key-` HEX: 0035 ; inline
-: key-, HEX: 0036 ; inline
-: key-. HEX: 0037 ; inline
-: key-/ HEX: 0038 ; inline
-: key-caps-lock HEX: 0039 ; inline
-: key-f1 HEX: 003a ; inline
-: key-f2 HEX: 003b ; inline
-: key-f3 HEX: 003c ; inline
-: key-f4 HEX: 003d ; inline
-: key-f5 HEX: 003e ; inline
-: key-f6 HEX: 003f ; inline
-: key-f7 HEX: 0040 ; inline
-: key-f8 HEX: 0041 ; inline
-: key-f9 HEX: 0042 ; inline
-: key-f10 HEX: 0043 ; inline
-: key-f11 HEX: 0044 ; inline
-: key-f12 HEX: 0045 ; inline
-: key-print-screen HEX: 0046 ; inline
-: key-scroll-lock HEX: 0047 ; inline
-: key-pause HEX: 0048 ; inline
-: key-insert HEX: 0049 ; inline
-: key-home HEX: 004a ; inline
-: key-page-up HEX: 004b ; inline
-: key-delete HEX: 004c ; inline
-: key-end HEX: 004d ; inline
-: key-page-down HEX: 004e ; inline
-: key-right-arrow HEX: 004f ; inline
-: key-left-arrow HEX: 0050 ; inline
-: key-down-arrow HEX: 0051 ; inline
-: key-up-arrow HEX: 0052 ; inline
-: key-keypad-numlock HEX: 0053 ; inline
-: key-keypad-/ HEX: 0054 ; inline
-: key-keypad-* HEX: 0055 ; inline
-: key-keypad-- HEX: 0056 ; inline
-: key-keypad-+ HEX: 0057 ; inline
-: key-keypad-enter HEX: 0058 ; inline
-: key-keypad-1 HEX: 0059 ; inline
-: key-keypad-2 HEX: 005a ; inline
-: key-keypad-3 HEX: 005b ; inline
-: key-keypad-4 HEX: 005c ; inline
-: key-keypad-5 HEX: 005d ; inline
-: key-keypad-6 HEX: 005e ; inline
-: key-keypad-7 HEX: 005f ; inline
-: key-keypad-8 HEX: 0060 ; inline
-: key-keypad-9 HEX: 0061 ; inline
-: key-keypad-0 HEX: 0062 ; inline
-: key-keypad-. HEX: 0063 ; inline
-: key-\-non-us HEX: 0064 ; inline
-: key-application HEX: 0065 ; inline
-: key-power HEX: 0066 ; inline
-: key-keypad-= HEX: 0067 ; inline
-: key-f13 HEX: 0068 ; inline
-: key-f14 HEX: 0069 ; inline
-: key-f15 HEX: 006a ; inline
-: key-f16 HEX: 006b ; inline
-: key-f17 HEX: 006c ; inline
-: key-f18 HEX: 006d ; inline
-: key-f19 HEX: 006e ; inline
-: key-f20 HEX: 006f ; inline
-: key-f21 HEX: 0070 ; inline
-: key-f22 HEX: 0071 ; inline
-: key-f23 HEX: 0072 ; inline
-: key-f24 HEX: 0073 ; inline
-: key-execute HEX: 0074 ; inline
-: key-help HEX: 0075 ; inline
-: key-menu HEX: 0076 ; inline
-: key-select HEX: 0077 ; inline
-: key-stop HEX: 0078 ; inline
-: key-again HEX: 0079 ; inline
-: key-undo HEX: 007a ; inline
-: key-cut HEX: 007b ; inline
-: key-copy HEX: 007c ; inline
-: key-paste HEX: 007d ; inline
-: key-find HEX: 007e ; inline
-: key-mute HEX: 007f ; inline
-: key-volume-up HEX: 0080 ; inline
-: key-volume-down HEX: 0081 ; inline
-: key-locking-caps-lock HEX: 0082 ; inline
-: key-locking-num-lock HEX: 0083 ; inline
-: key-locking-scroll-lock HEX: 0084 ; inline
-: key-keypad-, HEX: 0085 ; inline
-: key-keypad-=-as-400 HEX: 0086 ; inline
-: key-international-1 HEX: 0087 ; inline
-: key-international-2 HEX: 0088 ; inline
-: key-international-3 HEX: 0089 ; inline
-: key-international-4 HEX: 008a ; inline
-: key-international-5 HEX: 008b ; inline
-: key-international-6 HEX: 008c ; inline
-: key-international-7 HEX: 008d ; inline
-: key-international-8 HEX: 008e ; inline
-: key-international-9 HEX: 008f ; inline
-: key-lang-1 HEX: 0090 ; inline
-: key-lang-2 HEX: 0091 ; inline
-: key-lang-3 HEX: 0092 ; inline
-: key-lang-4 HEX: 0093 ; inline
-: key-lang-5 HEX: 0094 ; inline
-: key-lang-6 HEX: 0095 ; inline
-: key-lang-7 HEX: 0096 ; inline
-: key-lang-8 HEX: 0097 ; inline
-: key-lang-9 HEX: 0098 ; inline
-: key-alternate-erase HEX: 0099 ; inline
-: key-sysreq HEX: 009a ; inline
-: key-cancel HEX: 009b ; inline
-: key-clear HEX: 009c ; inline
-: key-prior HEX: 009d ; inline
-: key-enter HEX: 009e ; inline
-: key-separator HEX: 009f ; inline
-: key-out HEX: 00a0 ; inline
-: key-oper HEX: 00a1 ; inline
-: key-clear-again HEX: 00a2 ; inline
-: key-crsel-props HEX: 00a3 ; inline
-: key-exsel HEX: 00a4 ; inline
-: key-left-control HEX: 00e0 ; inline
-: key-left-shift HEX: 00e1 ; inline
-: key-left-alt HEX: 00e2 ; inline
-: key-left-gui HEX: 00e3 ; inline
-: key-right-control HEX: 00e4 ; inline
-: key-right-shift HEX: 00e5 ; inline
-: key-right-alt HEX: 00e6 ; inline
-: key-right-gui HEX: 00e7 ; inline
+CONSTANT: key-undefined HEX: 0000
+CONSTANT: key-error-roll-over HEX: 0001
+CONSTANT: key-error-post-fail HEX: 0002
+CONSTANT: key-error-undefined HEX: 0003
+CONSTANT: key-a HEX: 0004
+CONSTANT: key-b HEX: 0005
+CONSTANT: key-c HEX: 0006
+CONSTANT: key-d HEX: 0007
+CONSTANT: key-e HEX: 0008
+CONSTANT: key-f HEX: 0009
+CONSTANT: key-g HEX: 000a
+CONSTANT: key-h HEX: 000b
+CONSTANT: key-i HEX: 000c
+CONSTANT: key-j HEX: 000d
+CONSTANT: key-k HEX: 000e
+CONSTANT: key-l HEX: 000f
+CONSTANT: key-m HEX: 0010
+CONSTANT: key-n HEX: 0011
+CONSTANT: key-o HEX: 0012
+CONSTANT: key-p HEX: 0013
+CONSTANT: key-q HEX: 0014
+CONSTANT: key-r HEX: 0015
+CONSTANT: key-s HEX: 0016
+CONSTANT: key-t HEX: 0017
+CONSTANT: key-u HEX: 0018
+CONSTANT: key-v HEX: 0019
+CONSTANT: key-w HEX: 001a
+CONSTANT: key-x HEX: 001b
+CONSTANT: key-y HEX: 001c
+CONSTANT: key-z HEX: 001d
+CONSTANT: key-1 HEX: 001e
+CONSTANT: key-2 HEX: 001f
+CONSTANT: key-3 HEX: 0020
+CONSTANT: key-4 HEX: 0021
+CONSTANT: key-5 HEX: 0022
+CONSTANT: key-6 HEX: 0023
+CONSTANT: key-7 HEX: 0024
+CONSTANT: key-8 HEX: 0025
+CONSTANT: key-9 HEX: 0026
+CONSTANT: key-0 HEX: 0027
+CONSTANT: key-return HEX: 0028
+CONSTANT: key-escape HEX: 0029
+CONSTANT: key-backspace HEX: 002a
+CONSTANT: key-tab HEX: 002b
+CONSTANT: key-space HEX: 002c
+CONSTANT: key-- HEX: 002d
+CONSTANT: key-= HEX: 002e
+CONSTANT: key-[ HEX: 002f
+CONSTANT: key-] HEX: 0030
+CONSTANT: key-\ HEX: 0031
+CONSTANT: key-#-non-us HEX: 0032
+CONSTANT: key-; HEX: 0033
+CONSTANT: key-' HEX: 0034
+CONSTANT: key-` HEX: 0035
+CONSTANT: key-, HEX: 0036
+CONSTANT: key-. HEX: 0037
+CONSTANT: key-/ HEX: 0038
+CONSTANT: key-caps-lock HEX: 0039
+CONSTANT: key-f1 HEX: 003a
+CONSTANT: key-f2 HEX: 003b
+CONSTANT: key-f3 HEX: 003c
+CONSTANT: key-f4 HEX: 003d
+CONSTANT: key-f5 HEX: 003e
+CONSTANT: key-f6 HEX: 003f
+CONSTANT: key-f7 HEX: 0040
+CONSTANT: key-f8 HEX: 0041
+CONSTANT: key-f9 HEX: 0042
+CONSTANT: key-f10 HEX: 0043
+CONSTANT: key-f11 HEX: 0044
+CONSTANT: key-f12 HEX: 0045
+CONSTANT: key-print-screen HEX: 0046
+CONSTANT: key-scroll-lock HEX: 0047
+CONSTANT: key-pause HEX: 0048
+CONSTANT: key-insert HEX: 0049
+CONSTANT: key-home HEX: 004a
+CONSTANT: key-page-up HEX: 004b
+CONSTANT: key-delete HEX: 004c
+CONSTANT: key-end HEX: 004d
+CONSTANT: key-page-down HEX: 004e
+CONSTANT: key-right-arrow HEX: 004f
+CONSTANT: key-left-arrow HEX: 0050
+CONSTANT: key-down-arrow HEX: 0051
+CONSTANT: key-up-arrow HEX: 0052
+CONSTANT: key-keypad-numlock HEX: 0053
+CONSTANT: key-keypad-/ HEX: 0054
+CONSTANT: key-keypad-* HEX: 0055
+CONSTANT: key-keypad-- HEX: 0056
+CONSTANT: key-keypad-+ HEX: 0057
+CONSTANT: key-keypad-enter HEX: 0058
+CONSTANT: key-keypad-1 HEX: 0059
+CONSTANT: key-keypad-2 HEX: 005a
+CONSTANT: key-keypad-3 HEX: 005b
+CONSTANT: key-keypad-4 HEX: 005c
+CONSTANT: key-keypad-5 HEX: 005d
+CONSTANT: key-keypad-6 HEX: 005e
+CONSTANT: key-keypad-7 HEX: 005f
+CONSTANT: key-keypad-8 HEX: 0060
+CONSTANT: key-keypad-9 HEX: 0061
+CONSTANT: key-keypad-0 HEX: 0062
+CONSTANT: key-keypad-. HEX: 0063
+CONSTANT: key-\-non-us HEX: 0064
+CONSTANT: key-application HEX: 0065
+CONSTANT: key-power HEX: 0066
+CONSTANT: key-keypad-= HEX: 0067
+CONSTANT: key-f13 HEX: 0068
+CONSTANT: key-f14 HEX: 0069
+CONSTANT: key-f15 HEX: 006a
+CONSTANT: key-f16 HEX: 006b
+CONSTANT: key-f17 HEX: 006c
+CONSTANT: key-f18 HEX: 006d
+CONSTANT: key-f19 HEX: 006e
+CONSTANT: key-f20 HEX: 006f
+CONSTANT: key-f21 HEX: 0070
+CONSTANT: key-f22 HEX: 0071
+CONSTANT: key-f23 HEX: 0072
+CONSTANT: key-f24 HEX: 0073
+CONSTANT: key-execute HEX: 0074
+CONSTANT: key-help HEX: 0075
+CONSTANT: key-menu HEX: 0076
+CONSTANT: key-select HEX: 0077
+CONSTANT: key-stop HEX: 0078
+CONSTANT: key-again HEX: 0079
+CONSTANT: key-undo HEX: 007a
+CONSTANT: key-cut HEX: 007b
+CONSTANT: key-copy HEX: 007c
+CONSTANT: key-paste HEX: 007d
+CONSTANT: key-find HEX: 007e
+CONSTANT: key-mute HEX: 007f
+CONSTANT: key-volume-up HEX: 0080
+CONSTANT: key-volume-down HEX: 0081
+CONSTANT: key-locking-caps-lock HEX: 0082
+CONSTANT: key-locking-num-lock HEX: 0083
+CONSTANT: key-locking-scroll-lock HEX: 0084
+CONSTANT: key-keypad-, HEX: 0085
+CONSTANT: key-keypad-=-as-400 HEX: 0086
+CONSTANT: key-international-1 HEX: 0087
+CONSTANT: key-international-2 HEX: 0088
+CONSTANT: key-international-3 HEX: 0089
+CONSTANT: key-international-4 HEX: 008a
+CONSTANT: key-international-5 HEX: 008b
+CONSTANT: key-international-6 HEX: 008c
+CONSTANT: key-international-7 HEX: 008d
+CONSTANT: key-international-8 HEX: 008e
+CONSTANT: key-international-9 HEX: 008f
+CONSTANT: key-lang-1 HEX: 0090
+CONSTANT: key-lang-2 HEX: 0091
+CONSTANT: key-lang-3 HEX: 0092
+CONSTANT: key-lang-4 HEX: 0093
+CONSTANT: key-lang-5 HEX: 0094
+CONSTANT: key-lang-6 HEX: 0095
+CONSTANT: key-lang-7 HEX: 0096
+CONSTANT: key-lang-8 HEX: 0097
+CONSTANT: key-lang-9 HEX: 0098
+CONSTANT: key-alternate-erase HEX: 0099
+CONSTANT: key-sysreq HEX: 009a
+CONSTANT: key-cancel HEX: 009b
+CONSTANT: key-clear HEX: 009c
+CONSTANT: key-prior HEX: 009d
+CONSTANT: key-enter HEX: 009e
+CONSTANT: key-separator HEX: 009f
+CONSTANT: key-out HEX: 00a0
+CONSTANT: key-oper HEX: 00a1
+CONSTANT: key-clear-again HEX: 00a2
+CONSTANT: key-crsel-props HEX: 00a3
+CONSTANT: key-exsel HEX: 00a4
+CONSTANT: key-left-control HEX: 00e0
+CONSTANT: key-left-shift HEX: 00e1
+CONSTANT: key-left-alt HEX: 00e2
+CONSTANT: key-left-gui HEX: 00e3
+CONSTANT: key-right-control HEX: 00e4
+CONSTANT: key-right-shift HEX: 00e5
+CONSTANT: key-right-alt HEX: 00e6
+CONSTANT: key-right-gui HEX: 00e7
compiler.cfg.optimizer fry ;
IN: google-tech-talk
-: google-slides
+CONSTANT: google-slides
{
{ $slide "Factor!"
{ $url "http://factorcode.org" }
"Put your prejudices aside and give it a shot!"
}
{ $slide "Questions?" }
-} ;
+}
: google-talk ( -- ) google-slides slides-window ;
Tim Wawrzynczak
-
+Doug Coleman
! Copyright (C) 2008 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax sequences kernel ;
+USING: help.markup help.syntax sequences kernel accessors ;
IN: id3
HELP: file-id3-tags
{ $values
{ "path" "a path string" }
- { "object/f" "a tuple storing ID3 metadata or f" } }
-{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ;
+ { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
+ { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: "
+ $nl { $link title>> }
+ $nl { $link artist>> }
+ $nl { $link album>> }
+ $nl { $link year>> }
+ $nl { $link genre>> }
+ $nl { $link comment>> } } ;
ARTICLE: "id3" "ID3 tags"
"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl
! Copyright (C) 2009 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test id3 ;
+USING: tools.test id3 combinators ;
IN: id3.tests
-[ T{ mp3v2-file
- { header T{ header f t 0 502 } }
- { frames
- {
- T{ frame
- { frame-id "COMM" }
- { flags B{ 0 0 } }
- { size 19 }
- { data "eng, AG# 08E1C12E" }
- }
- T{ frame
- { frame-id "TIT2" }
- { flags B{ 0 0 } }
- { size 15 }
- { data "Stormy Weather" }
- }
- T{ frame
- { frame-id "TRCK" }
- { flags B{ 0 0 } }
- { size 3 }
- { data "32" }
- }
- T{ frame
- { frame-id "TCON" }
- { flags B{ 0 0 } }
- { size 5 }
- { data "(96)" }
- }
- T{ frame
- { frame-id "TALB" }
- { flags B{ 0 0 } }
- { size 28 }
- { data "Night and Day Frank Sinatra" }
- }
- T{ frame
- { frame-id "PRIV" }
- { flags B{ 0 0 } }
- { size 39 }
- { data "WM/MediaClassPrimaryID�}`�#��K�H�*(D" }
- }
- T{ frame
- { frame-id "PRIV" }
- { flags B{ 0 0 } }
- { size 41 }
- { data "WM/MediaClassSecondaryID" }
- }
- T{ frame
- { frame-id "TPE1" }
- { flags B{ 0 0 } }
- { size 14 }
- { data "Frank Sinatra" }
- }
- }
- }
-}
-] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test
+: id3-params ( id3 -- title artist album year comment genre )
+ {
+ [ id3-title ]
+ [ id3-artist ]
+ [ id3-album ]
+ [ id3-year ]
+ [ id3-comment ]
+ [ id3-genre ]
+ } cleave ;
[
- T{ mp3v2-file
- { header
- T{ header { version t } { flags 0 } { size 1405 } }
- }
- { frames
- {
- T{ frame
- { frame-id "TIT2" }
- { flags B{ 0 0 } }
- { size 22 }
- { data "Anthem of the Trinity" }
- }
- T{ frame
- { frame-id "TPE1" }
- { flags B{ 0 0 } }
- { size 12 }
- { data "Terry Riley" }
- }
- T{ frame
- { frame-id "TALB" }
- { flags B{ 0 0 } }
- { size 11 }
- { data "Shri Camel" }
- }
- T{ frame
- { frame-id "TCON" }
- { flags B{ 0 0 } }
- { size 10 }
- { data "Classical" }
- }
- T{ frame
- { frame-id "UFID" }
- { flags B{ 0 0 } }
- { size 23 }
- { data "http://musicbrainz.org" }
- }
- T{ frame
- { frame-id "TXXX" }
- { flags B{ 0 0 } }
- { size 23 }
- { data "MusicBrainz Artist Id" }
- }
- T{ frame
- { frame-id "TXXX" }
- { flags B{ 0 0 } }
- { size 22 }
- { data "musicbrainz_artistid" }
- }
- T{ frame
- { frame-id "TRCK" }
- { flags B{ 0 0 } }
- { size 2 }
- { data "1" }
- }
- T{ frame
- { frame-id "TXXX" }
- { flags B{ 0 0 } }
- { size 22 }
- { data "MusicBrainz Album Id" }
- }
- T{ frame
- { frame-id "TXXX" }
- { flags B{ 0 0 } }
- { size 21 }
- { data "musicbrainz_albumid" }
- }
- T{ frame
- { frame-id "TXXX" }
- { flags B{ 0 0 } }
- { size 29 }
- { data "MusicBrainz Album Artist Id" }
- }
- T{ frame
- { frame-id "TXXX" }
- { flags B{ 0 0 } }
- { size 27 }
- { data "musicbrainz_albumartistid" }
- }
- T{ frame
- { frame-id "TPOS" }
- { flags B{ 0 0 } }
- { size 2 }
- { data "1" }
- }
- T{ frame
- { frame-id "TSOP" }
- { flags B{ 0 0 } }
- { size 1 }
- }
- T{ frame
- { frame-id "TMED" }
- { flags B{ 0 0 } }
- { size 4 }
- { data "DIG" }
- }
- }
- }
-}
-] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test
+ "BLAH"
+ "ARTIST"
+ "ALBUM"
+ "2009"
+ "COMMENT"
+ "Bluegrass"
+] [ "vocab:id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test
+
+[
+ "Anthem of the Trinity"
+ "Terry Riley"
+ "Shri Camel"
+ f
+ f
+ "Classical"
+] [ "vocab:id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test
[
- T{ mp3v1-file
- { title
- "BLAH"
- }
- { artist
- "ARTIST"
- }
- { album
- "ALBUM"
- }
- { year "2009" }
- { comment
- "COMMENT"
- }
- { genre 89 }
- }
-] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test
+ "Stormy Weather"
+ "Frank Sinatra"
+ "Night and Day Frank Sinatra"
+ f
+ "eng, AG# 08E1C12E"
+ "Big Band"
+] [ "vocab:id3/tests/blah3.mp3" file-id3-tags id3-params ] unit-test
-! Copyright (C) 2009 Tim Wawrzynczak
+! Copyright (C) 2009 Tim Wawrzynczak, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ;
+USING: sequences io io.encodings.binary io.files io.pathnames
+strings kernel math io.mmap io.mmap.uchar accessors syntax
+combinators math.ranges unicode.categories byte-arrays
+io.encodings.string io.encodings.utf16 assocs math.parser
+combinators.short-circuit fry namespaces combinators.smart
+splitting io.encodings.ascii arrays ;
IN: id3
-! tuples
+<PRIVATE
+
+CONSTANT: genres
+ {
+ "Blues" "Classic Rock" "Country" "Dance" "Disco" "Funk"
+ "Grunge" "Hip-Hop" "Jazz" "Metal" "New Age" "Oldies" "Other"
+ "Pop" "R&B" "Rap" "Reggae" "Rock" "Techno" "Industrial"
+ "Alternative" "Ska" "Death Metal" "Pranks" "Soundtrack"
+ "Euro-Techno" "Ambient" "Trip-Hop" "Vocal" "Jazz+Funk"
+ "Fusion" "Trance" "Classical" "Instrumental" "Acid" "House"
+ "Game" "Sound Clip" "Gospel" "Noise" "AlternRock" "Bass"
+ "Soul" "Punk" "Space" "Meditative" "Instrumental Pop"
+ "Instrumental Rock" "Ethnic" "Gothic" "Darkwave"
+ "Techno-Industrial" "Electronic" "Pop-Folk" "Eurodance"
+ "Dream" "Southern Rock" "Comedy" "Cult" "Gangsta" "Top 40"
+ "Christian Rap" "Pop/Funk" "Jungle" "Native American"
+ "Cabaret" "New Wave" "Psychedelic" "Rave" "Showtunes"
+ "Trailer" "Lo-Fi" "Tribal" "Acid Punk" "Acid Jazz" "Polka"
+ "Retro" "Musical" "Rock & Roll" "Hard Rock" "Folk"
+ "Folk-Rock" "National Folk" "Swing" "Fast Fusion" "Bebop"
+ "Latin" "Revival" "Celtic" "Bluegrass" "Avantgarde"
+ "Gothic Rock" "Progressive Rock" "Psychedelic Rock"
+ "Symphonic Rock" "Slow Rock" "Big Band" "Chorus"
+ "Easy Listening" "Acoustic" "Humour" "Speech" "Chanson"
+ "Opera" "Chamber Music" "Sonata" "Symphony" "Booty Bass"
+ "Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
+ "Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
+ "Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
+ "Euro-House" "Dance Hall"
+ }
TUPLE: header version flags size ;
TUPLE: frame frame-id flags size data ;
-TUPLE: mp3v2-file header frames ;
+TUPLE: id3v2-info header frames ;
-TUPLE: mp3v1-file title artist album year comment genre ;
+TUPLE: id3v1-info title artist album year comment genre ;
-: <mp3v1-file> ( -- object ) mp3v1-file new ;
+: <id3v1-info> ( -- object ) id3v1-info new ;
-: <mp3v2-file> ( header frames -- object ) mp3v2-file boa ;
+: <id3v2-info> ( header frames -- object )
+ [ [ frame-id>> ] keep ] H{ } map>assoc
+ id3v2-info boa ;
: <header> ( -- object ) header new ;
: <frame> ( -- object ) frame new ;
-<PRIVATE
+: id3v2? ( mmap -- ? ) "ID3" head? ; inline
-! utility words
+: id3v1? ( mmap -- ? )
+ { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
-: id3v2? ( mmap -- ? )
- "ID3" head? ;
+: id3v1-frame ( string key -- frame )
+ <frame>
+ swap >>frame-id
+ swap >>data ;
-: id3v1? ( mmap -- ? )
- 128 tail-slice* "TAG" head? ;
+: id3v1>id3v2 ( id3v1 -- id3v2 )
+ [
+ {
+ [ title>> "TIT2" id3v1-frame ]
+ [ artist>> "TPE1" id3v1-frame ]
+ [ album>> "TALB" id3v1-frame ]
+ [ year>> "TYER" id3v1-frame ]
+ [ comment>> "COMM" id3v1-frame ]
+ [ genre>> "TCON" id3v1-frame ]
+ } cleave
+ ] output>array f swap <id3v2-info> ;
: >28bitword ( seq -- int )
- 0 [ swap 7 shift bitor ] reduce ;
+ 0 [ [ 7 shift ] dip bitor ] reduce ; inline
: filter-text-data ( data -- filtered )
- [ printable? ] filter ;
-
-! frame details stuff
+ [ printable? ] filter ; inline
: valid-frame-id? ( id -- ? )
- [ [ digit? ] [ LETTER? ] bi or ] all? ;
-
-: read-frame-id ( mmap -- id )
- 4 head-slice ;
-
-: read-frame-size ( mmap -- size )
- [ 4 8 ] dip subseq ;
-
-: read-frame-flags ( mmap -- flags )
- [ 8 10 ] dip subseq ;
+ [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline
: read-frame-data ( frame mmap -- frame data )
- [ 10 over size>> 10 + ] dip <slice> filter-text-data ;
+ [ 10 over size>> 10 + ] dip <slice> filter-text-data ; inline
-! read whole frames
+: decode-text ( string -- string' )
+ dup 2 short head
+ { { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member?
+ utf16 ascii ? decode ; inline
: (read-frame) ( mmap -- frame )
[ <frame> ] dip
{
- [ read-frame-id ascii decode >>frame-id ]
- [ read-frame-flags >byte-array >>flags ]
- [ read-frame-size >28bitword >>size ]
- [ read-frame-data ascii decode >>data ]
+ [ 4 head-slice decode-text >>frame-id ]
+ [ [ 4 8 ] dip subseq >28bitword >>size ]
+ [ [ 8 10 ] dip subseq >byte-array >>flags ]
+ [ read-frame-data decode-text >>data ]
} cleave ;
: read-frame ( mmap -- frame/f )
- dup read-frame-id valid-frame-id? [ (read-frame) ] [ drop f ] if ;
+ dup 4 head-slice valid-frame-id?
+ [ (read-frame) ] [ drop f ] if ;
: remove-frame ( mmap frame -- mmap )
- size>> 10 + tail-slice ;
+ size>> 10 + tail-slice ; inline
: read-frames ( mmap -- frames )
[ dup read-frame dup ]
! header stuff
-: read-header-supported-version? ( mmap -- ? )
- 3 tail-slice [ { 4 } head? ] [ { 3 } head? ] bi or ;
-
-: read-header-flags ( mmap -- flags )
- 5 swap nth ;
-
-: read-header-size ( mmap -- size )
- [ 6 10 ] dip <slice> >28bitword ;
-
-: read-v2-header ( mmap -- id3header )
+: read-v2-header ( seq -- id3header )
[ <header> ] dip
{
- [ read-header-supported-version? >>version ]
- [ read-header-flags >>flags ]
- [ read-header-size >>size ]
- } cleave ;
-
-: drop-header ( mmap -- seq1 seq2 )
- dup 10 tail-slice swap ;
+ [ [ 3 5 ] dip <slice> >array >>version ]
+ [ [ 5 ] dip nth >>flags ]
+ [ [ 6 10 ] dip <slice> >28bitword >>size ]
+ } cleave ; inline
+
+: read-v2-tag-data ( seq -- id3v2-info )
+ 10 cut-slice
+ [ read-v2-header ]
+ [ read-frames ] bi* <id3v2-info> ; inline
+
+! v1 information
-: read-v2-tag-data ( seq -- mp3v2-file )
- drop-header read-v2-header swap read-frames <mp3v2-file> ;
+: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
-! v1 information
+: (read-v1-tag-data) ( seq -- mp3-file )
+ [ <id3v1-info> ] dip
+ {
+ [ 30 head-slice decode-text filter-text-data >>title ]
+ [ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ]
+ [ [ 60 90 ] dip subseq decode-text filter-text-data >>album ]
+ [ [ 90 94 ] dip subseq decode-text filter-text-data >>year ]
+ [ [ 94 124 ] dip subseq decode-text filter-text-data >>comment ]
+ [ [ 124 ] dip nth number>string >>genre ]
+ } cleave ; inline
-: skip-to-v1-data ( seq -- seq )
- 125 tail-slice* ;
+: read-v1-tag-data ( seq -- mp3-file )
+ skip-to-v1-data (read-v1-tag-data) ; inline
-: read-title ( seq -- title )
- 30 head-slice ;
+: parse-genre ( string -- n/f )
+ dup "(" ?head-slice drop ")" ?tail-slice drop
+ string>number dup number? [
+ genres ?nth swap or
+ ] [
+ drop
+ ] if ; inline
-: read-artist ( seq -- title )
- [ 30 60 ] dip subseq ;
+PRIVATE>
-: read-album ( seq -- album )
- [ 60 90 ] dip subseq ;
+: frame-named ( id3 name quot -- obj )
+ [ swap frames>> at* ] dip
+ [ data>> ] prepose [ drop f ] if ; inline
-: read-year ( seq -- year )
- [ 90 94 ] dip subseq ;
+: id3-title ( id3 -- title/f ) "TIT2" [ ] frame-named ; inline
-: read-comment ( seq -- comment )
- [ 94 124 ] dip subseq ;
+: id3-artist ( id3 -- artist/f ) "TPE1" [ ] frame-named ; inline
-: read-genre ( seq -- genre )
- [ 124 ] dip nth ;
+: id3-album ( id3 -- album/f ) "TALB" [ ] frame-named ; inline
-: (read-v1-tag-data) ( seq -- mp3-file )
- [ <mp3v1-file> ] dip
- {
- [ read-title ascii decode filter-text-data >>title ]
- [ read-artist ascii decode filter-text-data >>artist ]
- [ read-album ascii decode filter-text-data >>album ]
- [ read-year ascii decode filter-text-data >>year ]
- [ read-comment ascii decode filter-text-data >>comment ]
- [ read-genre >fixnum >>genre ]
- } cleave ;
+: id3-year ( id3 -- year/f ) "TYER" [ ] frame-named ; inline
-: read-v1-tag-data ( seq -- mp3-file )
- skip-to-v1-data (read-v1-tag-data) ;
+: id3-comment ( id3 -- comment/f ) "COMM" [ ] frame-named ; inline
-PRIVATE>
+: id3-genre ( id3 -- genre/f )
+ "TCON" [ parse-genre ] frame-named ; inline
-! main stuff
+: id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline
-: file-id3-tags ( path -- object/f )
+: file-id3-tags ( path -- id3v2-info/f )
[
{
- { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file )
- { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file )
- [ drop f ] ! ( mmap -- f )
+ { [ dup id3v2? ] [ read-v2-tag-data ] }
+ { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] }
+ [ drop f ]
} cond
] with-mapped-uchar-file ;
-
-! end
M: local-not-defined summary
drop "local is not defined" ;
-: at? ( key assoc -- value/key ? )
- dupd at* [ nip t ] [ drop f ] if ;
-
: >local-word ( string -- word )
- locals get at? [ local-not-defined ] unless ;
+ locals get ?at [ local-not-defined ] unless ;
: select-op ( string -- word )
{
"Baud rate " " not supported" surround ;
HOOK: lookup-baud os ( m -- n )
-HOOK: open-serial os ( serial -- stream )
+HOOK: open-serial os ( serial -- serial' )
+M: serial dispose ( serial -- ) stream>> dispose ;
{
{ [ os unix? ] [ "io.serial.unix" ] }
+ { [ os windows? ] [ "io.serial.windows" ] }
} cond require
230400 460800 921600
} member? [ invalid-baud ] unless ;
-: TCSANOW 0 ; inline
-: TCSADRAIN 1 ; inline
-: TCSAFLUSH 2 ; inline
-: TCSASOFT HEX: 10 ; inline
+CONSTANT: TCSANOW 0
+CONSTANT: TCSADRAIN 1
+CONSTANT: TCSAFLUSH 2
+CONSTANT: TCSASOFT HEX: 10
-: TCIFLUSH 1 ; inline
-: TCOFLUSH 2 ; inline
-: TCIOFLUSH 3 ; inline
-: TCOOFF 1 ; inline
-: TCOON 2 ; inline
-: TCIOFF 3 ; inline
-: TCION 4 ; inline
+CONSTANT: TCIFLUSH 1
+CONSTANT: TCOFLUSH 2
+CONSTANT: TCIOFLUSH 3
+CONSTANT: TCOOFF 1
+CONSTANT: TCOON 2
+CONSTANT: TCIOFF 3
+CONSTANT: TCION 4
! iflags
-: IGNBRK HEX: 00000001 ; inline
-: BRKINT HEX: 00000002 ; inline
-: IGNPAR HEX: 00000004 ; inline
-: PARMRK HEX: 00000008 ; inline
-: INPCK HEX: 00000010 ; inline
-: ISTRIP HEX: 00000020 ; inline
-: INLCR HEX: 00000040 ; inline
-: IGNCR HEX: 00000080 ; inline
-: ICRNL HEX: 00000100 ; inline
-: IXON HEX: 00000200 ; inline
-: IXOFF HEX: 00000400 ; inline
-: IXANY HEX: 00000800 ; inline
-: IMAXBEL HEX: 00002000 ; inline
-: IUTF8 HEX: 00004000 ; inline
+CONSTANT: IGNBRK HEX: 00000001
+CONSTANT: BRKINT HEX: 00000002
+CONSTANT: IGNPAR HEX: 00000004
+CONSTANT: PARMRK HEX: 00000008
+CONSTANT: INPCK HEX: 00000010
+CONSTANT: ISTRIP HEX: 00000020
+CONSTANT: INLCR HEX: 00000040
+CONSTANT: IGNCR HEX: 00000080
+CONSTANT: ICRNL HEX: 00000100
+CONSTANT: IXON HEX: 00000200
+CONSTANT: IXOFF HEX: 00000400
+CONSTANT: IXANY HEX: 00000800
+CONSTANT: IMAXBEL HEX: 00002000
+CONSTANT: IUTF8 HEX: 00004000
! oflags
-: OPOST HEX: 00000001 ; inline
-: ONLCR HEX: 00000002 ; inline
-: OXTABS HEX: 00000004 ; inline
-: ONOEOT HEX: 00000008 ; inline
+CONSTANT: OPOST HEX: 00000001
+CONSTANT: ONLCR HEX: 00000002
+CONSTANT: OXTABS HEX: 00000004
+CONSTANT: ONOEOT HEX: 00000008
! cflags
-: CIGNORE HEX: 00000001 ; inline
-: CSIZE HEX: 00000300 ; inline
-: CS5 HEX: 00000000 ; inline
-: CS6 HEX: 00000100 ; inline
-: CS7 HEX: 00000200 ; inline
-: CS8 HEX: 00000300 ; inline
-: CSTOPB HEX: 00000400 ; inline
-: CREAD HEX: 00000800 ; inline
-: PARENB HEX: 00001000 ; inline
-: PARODD HEX: 00002000 ; inline
-: HUPCL HEX: 00004000 ; inline
-: CLOCAL HEX: 00008000 ; inline
-: CCTS_OFLOW HEX: 00010000 ; inline
-: CRTS_IFLOW HEX: 00020000 ; inline
-: CRTSCTS { CCTS_OFLOW CRTS_IFLOW } flags ; inline
-: CDTR_IFLOW HEX: 00040000 ; inline
-: CDSR_OFLOW HEX: 00080000 ; inline
-: CCAR_OFLOW HEX: 00100000 ; inline
-: MDMBUF HEX: 00100000 ; inline
+CONSTANT: CIGNORE HEX: 00000001
+CONSTANT: CSIZE HEX: 00000300
+CONSTANT: CS5 HEX: 00000000
+CONSTANT: CS6 HEX: 00000100
+CONSTANT: CS7 HEX: 00000200
+CONSTANT: CS8 HEX: 00000300
+CONSTANT: CSTOPB HEX: 00000400
+CONSTANT: CREAD HEX: 00000800
+CONSTANT: PARENB HEX: 00001000
+CONSTANT: PARODD HEX: 00002000
+CONSTANT: HUPCL HEX: 00004000
+CONSTANT: CLOCAL HEX: 00008000
+CONSTANT: CCTS_OFLOW HEX: 00010000
+CONSTANT: CRTS_IFLOW HEX: 00020000
+: CRTSCTS ( -- n ) { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+CONSTANT: CDTR_IFLOW HEX: 00040000
+CONSTANT: CDSR_OFLOW HEX: 00080000
+CONSTANT: CCAR_OFLOW HEX: 00100000
+CONSTANT: MDMBUF HEX: 00100000
! lflags
-: ECHOKE HEX: 00000001 ; inline
-: ECHOE HEX: 00000002 ; inline
-: ECHOK HEX: 00000004 ; inline
-: ECHO HEX: 00000008 ; inline
-: ECHONL HEX: 00000010 ; inline
-: ECHOPRT HEX: 00000020 ; inline
-: ECHOCTL HEX: 00000040 ; inline
-: ISIG HEX: 00000080 ; inline
-: ICANON HEX: 00000100 ; inline
-: ALTWERASE HEX: 00000200 ; inline
-: IEXTEN HEX: 00000400 ; inline
-: EXTPROC HEX: 00000800 ; inline
-: TOSTOP HEX: 00400000 ; inline
-: FLUSHO HEX: 00800000 ; inline
-: NOKERNINFO HEX: 02000000 ; inline
-: PENDIN HEX: 20000000 ; inline
-: NOFLSH HEX: 80000000 ; inline
+CONSTANT: ECHOKE HEX: 00000001
+CONSTANT: ECHOE HEX: 00000002
+CONSTANT: ECHOK HEX: 00000004
+CONSTANT: ECHO HEX: 00000008
+CONSTANT: ECHONL HEX: 00000010
+CONSTANT: ECHOPRT HEX: 00000020
+CONSTANT: ECHOCTL HEX: 00000040
+CONSTANT: ISIG HEX: 00000080
+CONSTANT: ICANON HEX: 00000100
+CONSTANT: ALTWERASE HEX: 00000200
+CONSTANT: IEXTEN HEX: 00000400
+CONSTANT: EXTPROC HEX: 00000800
+CONSTANT: TOSTOP HEX: 00400000
+CONSTANT: FLUSHO HEX: 00800000
+CONSTANT: NOKERNINFO HEX: 02000000
+CONSTANT: PENDIN HEX: 20000000
+CONSTANT: NOFLSH HEX: 80000000
USING: assocs alien.syntax kernel io.serial system unix ;
IN: io.serial.unix
-: TCSANOW 0 ; inline
-: TCSADRAIN 1 ; inline
-: TCSAFLUSH 2 ; inline
+CONSTANT: TCSANOW 0
+CONSTANT: TCSADRAIN 1
+CONSTANT: TCSAFLUSH 2
-: TCIFLUSH 0 ; inline
-: TCOFLUSH 1 ; inline
-: TCIOFLUSH 2 ; inline
+CONSTANT: TCIFLUSH 0
+CONSTANT: TCOFLUSH 1
+CONSTANT: TCIOFLUSH 2
-: TCOOFF 0 ; inline
-: TCOON 1 ; inline
-: TCIOFF 2 ; inline
-: TCION 3 ; inline
+CONSTANT: TCOOFF 0
+CONSTANT: TCOON 1
+CONSTANT: TCIOFF 2
+CONSTANT: TCION 3
! iflag
-: IGNBRK OCT: 0000001 ; inline
-: BRKINT OCT: 0000002 ; inline
-: IGNPAR OCT: 0000004 ; inline
-: PARMRK OCT: 0000010 ; inline
-: INPCK OCT: 0000020 ; inline
-: ISTRIP OCT: 0000040 ; inline
-: INLCR OCT: 0000100 ; inline
-: IGNCR OCT: 0000200 ; inline
-: ICRNL OCT: 0000400 ; inline
-: IUCLC OCT: 0001000 ; inline
-: IXON OCT: 0002000 ; inline
-: IXANY OCT: 0004000 ; inline
-: IXOFF OCT: 0010000 ; inline
-: IMAXBEL OCT: 0020000 ; inline
-: IUTF8 OCT: 0040000 ; inline
+CONSTANT: IGNBRK OCT: 0000001
+CONSTANT: BRKINT OCT: 0000002
+CONSTANT: IGNPAR OCT: 0000004
+CONSTANT: PARMRK OCT: 0000010
+CONSTANT: INPCK OCT: 0000020
+CONSTANT: ISTRIP OCT: 0000040
+CONSTANT: INLCR OCT: 0000100
+CONSTANT: IGNCR OCT: 0000200
+CONSTANT: ICRNL OCT: 0000400
+CONSTANT: IUCLC OCT: 0001000
+CONSTANT: IXON OCT: 0002000
+CONSTANT: IXANY OCT: 0004000
+CONSTANT: IXOFF OCT: 0010000
+CONSTANT: IMAXBEL OCT: 0020000
+CONSTANT: IUTF8 OCT: 0040000
! oflag
-: OPOST OCT: 0000001 ; inline
-: OLCUC OCT: 0000002 ; inline
-: ONLCR OCT: 0000004 ; inline
-: OCRNL OCT: 0000010 ; inline
-: ONOCR OCT: 0000020 ; inline
-: ONLRET OCT: 0000040 ; inline
-: OFILL OCT: 0000100 ; inline
-: OFDEL OCT: 0000200 ; inline
-: NLDLY OCT: 0000400 ; inline
-: NL0 OCT: 0000000 ; inline
-: NL1 OCT: 0000400 ; inline
-: CRDLY OCT: 0003000 ; inline
-: CR0 OCT: 0000000 ; inline
-: CR1 OCT: 0001000 ; inline
-: CR2 OCT: 0002000 ; inline
-: CR3 OCT: 0003000 ; inline
-: TABDLY OCT: 0014000 ; inline
-: TAB0 OCT: 0000000 ; inline
-: TAB1 OCT: 0004000 ; inline
-: TAB2 OCT: 0010000 ; inline
-: TAB3 OCT: 0014000 ; inline
-: BSDLY OCT: 0020000 ; inline
-: BS0 OCT: 0000000 ; inline
-: BS1 OCT: 0020000 ; inline
-: FFDLY OCT: 0100000 ; inline
-: FF0 OCT: 0000000 ; inline
-: FF1 OCT: 0100000 ; inline
+CONSTANT: OPOST OCT: 0000001
+CONSTANT: OLCUC OCT: 0000002
+CONSTANT: ONLCR OCT: 0000004
+CONSTANT: OCRNL OCT: 0000010
+CONSTANT: ONOCR OCT: 0000020
+CONSTANT: ONLRET OCT: 0000040
+CONSTANT: OFILL OCT: 0000100
+CONSTANT: OFDEL OCT: 0000200
+CONSTANT: NLDLY OCT: 0000400
+CONSTANT: NL0 OCT: 0000000
+CONSTANT: NL1 OCT: 0000400
+CONSTANT: CRDLY OCT: 0003000
+CONSTANT: CR0 OCT: 0000000
+CONSTANT: CR1 OCT: 0001000
+CONSTANT: CR2 OCT: 0002000
+CONSTANT: CR3 OCT: 0003000
+CONSTANT: TABDLY OCT: 0014000
+CONSTANT: TAB0 OCT: 0000000
+CONSTANT: TAB1 OCT: 0004000
+CONSTANT: TAB2 OCT: 0010000
+CONSTANT: TAB3 OCT: 0014000
+CONSTANT: BSDLY OCT: 0020000
+CONSTANT: BS0 OCT: 0000000
+CONSTANT: BS1 OCT: 0020000
+CONSTANT: FFDLY OCT: 0100000
+CONSTANT: FF0 OCT: 0000000
+CONSTANT: FF1 OCT: 0100000
! cflags
-: CSIZE OCT: 0000060 ; inline
-: CS5 OCT: 0000000 ; inline
-: CS6 OCT: 0000020 ; inline
-: CS7 OCT: 0000040 ; inline
-: CS8 OCT: 0000060 ; inline
-: CSTOPB OCT: 0000100 ; inline
-: CREAD OCT: 0000200 ; inline
-: PARENB OCT: 0000400 ; inline
-: PARODD OCT: 0001000 ; inline
-: HUPCL OCT: 0002000 ; inline
-: CLOCAL OCT: 0004000 ; inline
-: CIBAUD OCT: 002003600000 ; inline
-: CRTSCTS OCT: 020000000000 ; inline
+CONSTANT: CSIZE OCT: 0000060
+CONSTANT: CS5 OCT: 0000000
+CONSTANT: CS6 OCT: 0000020
+CONSTANT: CS7 OCT: 0000040
+CONSTANT: CS8 OCT: 0000060
+CONSTANT: CSTOPB OCT: 0000100
+CONSTANT: CREAD OCT: 0000200
+CONSTANT: PARENB OCT: 0000400
+CONSTANT: PARODD OCT: 0001000
+CONSTANT: HUPCL OCT: 0002000
+CONSTANT: CLOCAL OCT: 0004000
+CONSTANT: CIBAUD OCT: 002003600000
+CONSTANT: CRTSCTS OCT: 020000000000
! lflags
-: ISIG OCT: 0000001 ; inline
-: ICANON OCT: 0000002 ; inline
-: XCASE OCT: 0000004 ; inline
-: ECHO OCT: 0000010 ; inline
-: ECHOE OCT: 0000020 ; inline
-: ECHOK OCT: 0000040 ; inline
-: ECHONL OCT: 0000100 ; inline
-: NOFLSH OCT: 0000200 ; inline
-: TOSTOP OCT: 0000400 ; inline
-: ECHOCTL OCT: 0001000 ; inline
-: ECHOPRT OCT: 0002000 ; inline
-: ECHOKE OCT: 0004000 ; inline
-: FLUSHO OCT: 0010000 ; inline
-: PENDIN OCT: 0040000 ; inline
-: IEXTEN OCT: 0100000 ; inline
+CONSTANT: ISIG OCT: 0000001
+CONSTANT: ICANON OCT: 0000002
+CONSTANT: XCASE OCT: 0000004
+CONSTANT: ECHO OCT: 0000010
+CONSTANT: ECHOE OCT: 0000020
+CONSTANT: ECHOK OCT: 0000040
+CONSTANT: ECHONL OCT: 0000100
+CONSTANT: NOFLSH OCT: 0000200
+CONSTANT: TOSTOP OCT: 0000400
+CONSTANT: ECHOCTL OCT: 0001000
+CONSTANT: ECHOPRT OCT: 0002000
+CONSTANT: ECHOKE OCT: 0004000
+CONSTANT: FLUSHO OCT: 0010000
+CONSTANT: PENDIN OCT: 0040000
+CONSTANT: IEXTEN OCT: 0100000
M: linux lookup-baud ( n -- n )
dup H{
{ 3000000 OCT: 0010015 }
{ 3500000 OCT: 0010016 }
{ 4000000 OCT: 0010017 }
- } at* [ nip ] [ drop invalid-baud ] if ;
+ } ?at [ invalid-baud ] unless ;
USING: alien.syntax kernel sequences system ;
IN: io.serial.unix.termios
-: NCCS 20 ; inline
+CONSTANT: NCCS 20
TYPEDEF: uint tcflag_t
TYPEDEF: uchar cc_t
USING: alien.syntax kernel system unix ;
IN: io.serial.unix.termios
-: NCCS 32 ; inline
+CONSTANT: NCCS 32
TYPEDEF: uchar cc_t
TYPEDEF: uint speed_t
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.bitwise serial serial.unix ;
+USING: accessors kernel math.bitwise io.serial io.serial.unix ;
IN: io.serial.unix
: serial-obj ( -- obj )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax combinators io.ports
-io.streams.duplex io.unix.backend system kernel math math.bitwise
-vocabs.loader unix io.serial io.serial.unix.termios ;
+io.streams.duplex system kernel math math.bitwise
+vocabs.loader unix io.serial io.serial.unix.termios io.backend.unix ;
IN: io.serial.unix
<< {
: <file-rw> ( path -- stream ) open-rw fd>duplex-stream ;
M: unix open-serial ( serial -- serial' )
+ dup
path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
- fd>duplex-stream ;
+ fd>duplex-stream >>stream ;
: serial-fd ( serial -- fd )
stream>> in>> handle>> fd>> ;
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files.windows io.streams.duplex kernel math
+math.bitwise windows.kernel32 accessors alien.c-types
+windows io.files.windows fry locals continuations ;
+IN: io.serial.windows
+
+: <serial-stream> ( path encoding -- duplex )
+ [ open-r/w dup ] dip <encoder-duplex> ;
+
+: get-comm-state ( duplex -- dcb )
+ in>> handle>>
+ "DCB" <c-object> tuck
+ GetCommState win32-error=0/f ;
+
+: set-comm-state ( duplex dcb -- )
+ [ in>> handle>> ] dip
+ SetCommState win32-error=0/f ;
+
+:: with-comm-state ( duplex quot: ( dcb -- ) -- )
+ duplex get-comm-state :> dcb
+ dcb clone quot curry [ dcb set-comm-state ] recover ; inline
system core-foundation ;
IN: iokit.hid
-: kIOHIDDeviceKey "IOHIDDevice" ; inline
-
-: kIOHIDTransportKey "Transport" ; inline
-: kIOHIDVendorIDKey "VendorID" ; inline
-: kIOHIDVendorIDSourceKey "VendorIDSource" ; inline
-: kIOHIDProductIDKey "ProductID" ; inline
-: kIOHIDVersionNumberKey "VersionNumber" ; inline
-: kIOHIDManufacturerKey "Manufacturer" ; inline
-: kIOHIDProductKey "Product" ; inline
-: kIOHIDSerialNumberKey "SerialNumber" ; inline
-: kIOHIDCountryCodeKey "CountryCode" ; inline
-: kIOHIDLocationIDKey "LocationID" ; inline
-: kIOHIDDeviceUsageKey "DeviceUsage" ; inline
-: kIOHIDDeviceUsagePageKey "DeviceUsagePage" ; inline
-: kIOHIDDeviceUsagePairsKey "DeviceUsagePairs" ; inline
-: kIOHIDPrimaryUsageKey "PrimaryUsage" ; inline
-: kIOHIDPrimaryUsagePageKey "PrimaryUsagePage" ; inline
-: kIOHIDMaxInputReportSizeKey "MaxInputReportSize" ; inline
-: kIOHIDMaxOutputReportSizeKey "MaxOutputReportSize" ; inline
-: kIOHIDMaxFeatureReportSizeKey "MaxFeatureReportSize" ; inline
-: kIOHIDReportIntervalKey "ReportInterval" ; inline
-
-: kIOHIDElementKey "Elements" ; inline
-
-: kIOHIDElementCookieKey "ElementCookie" ; inline
-: kIOHIDElementTypeKey "Type" ; inline
-: kIOHIDElementCollectionTypeKey "CollectionType" ; inline
-: kIOHIDElementUsageKey "Usage" ; inline
-: kIOHIDElementUsagePageKey "UsagePage" ; inline
-: kIOHIDElementMinKey "Min" ; inline
-: kIOHIDElementMaxKey "Max" ; inline
-: kIOHIDElementScaledMinKey "ScaledMin" ; inline
-: kIOHIDElementScaledMaxKey "ScaledMax" ; inline
-: kIOHIDElementSizeKey "Size" ; inline
-: kIOHIDElementReportSizeKey "ReportSize" ; inline
-: kIOHIDElementReportCountKey "ReportCount" ; inline
-: kIOHIDElementReportIDKey "ReportID" ; inline
-: kIOHIDElementIsArrayKey "IsArray" ; inline
-: kIOHIDElementIsRelativeKey "IsRelative" ; inline
-: kIOHIDElementIsWrappingKey "IsWrapping" ; inline
-: kIOHIDElementIsNonLinearKey "IsNonLinear" ; inline
-: kIOHIDElementHasPreferredStateKey "HasPreferredState" ; inline
-: kIOHIDElementHasNullStateKey "HasNullState" ; inline
-: kIOHIDElementFlagsKey "Flags" ; inline
-: kIOHIDElementUnitKey "Unit" ; inline
-: kIOHIDElementUnitExponentKey "UnitExponent" ; inline
-: kIOHIDElementNameKey "Name" ; inline
-: kIOHIDElementValueLocationKey "ValueLocation" ; inline
-: kIOHIDElementDuplicateIndexKey "DuplicateIndex" ; inline
-: kIOHIDElementParentCollectionKey "ParentCollection" ; inline
+CONSTANT: kIOHIDDeviceKey "IOHIDDevice"
+
+CONSTANT: kIOHIDTransportKey "Transport"
+CONSTANT: kIOHIDVendorIDKey "VendorID"
+CONSTANT: kIOHIDVendorIDSourceKey "VendorIDSource"
+CONSTANT: kIOHIDProductIDKey "ProductID"
+CONSTANT: kIOHIDVersionNumberKey "VersionNumber"
+CONSTANT: kIOHIDManufacturerKey "Manufacturer"
+CONSTANT: kIOHIDProductKey "Product"
+CONSTANT: kIOHIDSerialNumberKey "SerialNumber"
+CONSTANT: kIOHIDCountryCodeKey "CountryCode"
+CONSTANT: kIOHIDLocationIDKey "LocationID"
+CONSTANT: kIOHIDDeviceUsageKey "DeviceUsage"
+CONSTANT: kIOHIDDeviceUsagePageKey "DeviceUsagePage"
+CONSTANT: kIOHIDDeviceUsagePairsKey "DeviceUsagePairs"
+CONSTANT: kIOHIDPrimaryUsageKey "PrimaryUsage"
+CONSTANT: kIOHIDPrimaryUsagePageKey "PrimaryUsagePage"
+CONSTANT: kIOHIDMaxInputReportSizeKey "MaxInputReportSize"
+CONSTANT: kIOHIDMaxOutputReportSizeKey "MaxOutputReportSize"
+CONSTANT: kIOHIDMaxFeatureReportSizeKey "MaxFeatureReportSize"
+CONSTANT: kIOHIDReportIntervalKey "ReportInterval"
+
+CONSTANT: kIOHIDElementKey "Elements"
+
+CONSTANT: kIOHIDElementCookieKey "ElementCookie"
+CONSTANT: kIOHIDElementTypeKey "Type"
+CONSTANT: kIOHIDElementCollectionTypeKey "CollectionType"
+CONSTANT: kIOHIDElementUsageKey "Usage"
+CONSTANT: kIOHIDElementUsagePageKey "UsagePage"
+CONSTANT: kIOHIDElementMinKey "Min"
+CONSTANT: kIOHIDElementMaxKey "Max"
+CONSTANT: kIOHIDElementScaledMinKey "ScaledMin"
+CONSTANT: kIOHIDElementScaledMaxKey "ScaledMax"
+CONSTANT: kIOHIDElementSizeKey "Size"
+CONSTANT: kIOHIDElementReportSizeKey "ReportSize"
+CONSTANT: kIOHIDElementReportCountKey "ReportCount"
+CONSTANT: kIOHIDElementReportIDKey "ReportID"
+CONSTANT: kIOHIDElementIsArrayKey "IsArray"
+CONSTANT: kIOHIDElementIsRelativeKey "IsRelative"
+CONSTANT: kIOHIDElementIsWrappingKey "IsWrapping"
+CONSTANT: kIOHIDElementIsNonLinearKey "IsNonLinear"
+CONSTANT: kIOHIDElementHasPreferredStateKey "HasPreferredState"
+CONSTANT: kIOHIDElementHasNullStateKey "HasNullState"
+CONSTANT: kIOHIDElementFlagsKey "Flags"
+CONSTANT: kIOHIDElementUnitKey "Unit"
+CONSTANT: kIOHIDElementUnitExponentKey "UnitExponent"
+CONSTANT: kIOHIDElementNameKey "Name"
+CONSTANT: kIOHIDElementValueLocationKey "ValueLocation"
+CONSTANT: kIOHIDElementDuplicateIndexKey "DuplicateIndex"
+CONSTANT: kIOHIDElementParentCollectionKey "ParentCollection"
: kIOHIDElementVendorSpecificKey ( -- str )
cpu ppc? "VendorSpecifc" "VendorSpecific" ? ; inline
-: kIOHIDElementCookieMinKey "ElementCookieMin" ; inline
-: kIOHIDElementCookieMaxKey "ElementCookieMax" ; inline
-: kIOHIDElementUsageMinKey "UsageMin" ; inline
-: kIOHIDElementUsageMaxKey "UsageMax" ; inline
-
-: kIOHIDElementCalibrationMinKey "CalibrationMin" ; inline
-: kIOHIDElementCalibrationMaxKey "CalibrationMax" ; inline
-: kIOHIDElementCalibrationSaturationMinKey "CalibrationSaturationMin" ; inline
-: kIOHIDElementCalibrationSaturationMaxKey "CalibrationSaturationMax" ; inline
-: kIOHIDElementCalibrationDeadZoneMinKey "CalibrationDeadZoneMin" ; inline
-: kIOHIDElementCalibrationDeadZoneMaxKey "CalibrationDeadZoneMax" ; inline
-: kIOHIDElementCalibrationGranularityKey "CalibrationGranularity" ; inline
-
-: kIOHIDElementTypeInput_Misc 1 ; inline
-: kIOHIDElementTypeInput_Button 2 ; inline
-: kIOHIDElementTypeInput_Axis 3 ; inline
-: kIOHIDElementTypeInput_ScanCodes 4 ; inline
-: kIOHIDElementTypeOutput 129 ; inline
-: kIOHIDElementTypeFeature 257 ; inline
-: kIOHIDElementTypeCollection 513 ; inline
-
-: kIOHIDElementCollectionTypePhysical HEX: 00 ; inline
-: kIOHIDElementCollectionTypeApplication HEX: 01 ; inline
-: kIOHIDElementCollectionTypeLogical HEX: 02 ; inline
-: kIOHIDElementCollectionTypeReport HEX: 03 ; inline
-: kIOHIDElementCollectionTypeNamedArray HEX: 04 ; inline
-: kIOHIDElementCollectionTypeUsageSwitch HEX: 05 ; inline
-: kIOHIDElementCollectionTypeUsageModifier HEX: 06 ; inline
-
-: kIOHIDReportTypeInput 0 ; inline
-: kIOHIDReportTypeOutput 1 ; inline
-: kIOHIDReportTypeFeature 2 ; inline
-: kIOHIDReportTypeCount 3 ; inline
-
-: kIOHIDOptionsTypeNone HEX: 00 ; inline
-: kIOHIDOptionsTypeSeizeDevice HEX: 01 ; inline
-
-: kIOHIDQueueOptionsTypeNone HEX: 00 ; inline
-: kIOHIDQueueOptionsTypeEnqueueAll HEX: 01 ; inline
-
-: kIOHIDElementFlagsConstantMask HEX: 0001 ; inline
-: kIOHIDElementFlagsVariableMask HEX: 0002 ; inline
-: kIOHIDElementFlagsRelativeMask HEX: 0004 ; inline
-: kIOHIDElementFlagsWrapMask HEX: 0008 ; inline
-: kIOHIDElementFlagsNonLinearMask HEX: 0010 ; inline
-: kIOHIDElementFlagsNoPreferredMask HEX: 0020 ; inline
-: kIOHIDElementFlagsNullStateMask HEX: 0040 ; inline
-: kIOHIDElementFlagsVolativeMask HEX: 0080 ; inline
-: kIOHIDElementFlagsBufferedByteMask HEX: 0100 ; inline
-
-: kIOHIDValueScaleTypeCalibrated 0 ; inline
-: kIOHIDValueScaleTypePhysical 1 ; inline
-
-: kIOHIDTransactionDirectionTypeInput 0 ; inline
-: kIOHIDTransactionDirectionTypeOutput 1 ; inline
-
-: kIOHIDTransactionOptionDefaultOutputValue 1 ; inline
+CONSTANT: kIOHIDElementCookieMinKey "ElementCookieMin"
+CONSTANT: kIOHIDElementCookieMaxKey "ElementCookieMax"
+CONSTANT: kIOHIDElementUsageMinKey "UsageMin"
+CONSTANT: kIOHIDElementUsageMaxKey "UsageMax"
+
+CONSTANT: kIOHIDElementCalibrationMinKey "CalibrationMin"
+CONSTANT: kIOHIDElementCalibrationMaxKey "CalibrationMax"
+CONSTANT: kIOHIDElementCalibrationSaturationMinKey "CalibrationSaturationMin"
+CONSTANT: kIOHIDElementCalibrationSaturationMaxKey "CalibrationSaturationMax"
+CONSTANT: kIOHIDElementCalibrationDeadZoneMinKey "CalibrationDeadZoneMin"
+CONSTANT: kIOHIDElementCalibrationDeadZoneMaxKey "CalibrationDeadZoneMax"
+CONSTANT: kIOHIDElementCalibrationGranularityKey "CalibrationGranularity"
+
+CONSTANT: kIOHIDElementTypeInput_Misc 1
+CONSTANT: kIOHIDElementTypeInput_Button 2
+CONSTANT: kIOHIDElementTypeInput_Axis 3
+CONSTANT: kIOHIDElementTypeInput_ScanCodes 4
+CONSTANT: kIOHIDElementTypeOutput 129
+CONSTANT: kIOHIDElementTypeFeature 257
+CONSTANT: kIOHIDElementTypeCollection 513
+
+CONSTANT: kIOHIDElementCollectionTypePhysical HEX: 00
+CONSTANT: kIOHIDElementCollectionTypeApplication HEX: 01
+CONSTANT: kIOHIDElementCollectionTypeLogical HEX: 02
+CONSTANT: kIOHIDElementCollectionTypeReport HEX: 03
+CONSTANT: kIOHIDElementCollectionTypeNamedArray HEX: 04
+CONSTANT: kIOHIDElementCollectionTypeUsageSwitch HEX: 05
+CONSTANT: kIOHIDElementCollectionTypeUsageModifier HEX: 06
+
+CONSTANT: kIOHIDReportTypeInput 0
+CONSTANT: kIOHIDReportTypeOutput 1
+CONSTANT: kIOHIDReportTypeFeature 2
+CONSTANT: kIOHIDReportTypeCount 3
+
+CONSTANT: kIOHIDOptionsTypeNone HEX: 00
+CONSTANT: kIOHIDOptionsTypeSeizeDevice HEX: 01
+
+CONSTANT: kIOHIDQueueOptionsTypeNone HEX: 00
+CONSTANT: kIOHIDQueueOptionsTypeEnqueueAll HEX: 01
+
+CONSTANT: kIOHIDElementFlagsConstantMask HEX: 0001
+CONSTANT: kIOHIDElementFlagsVariableMask HEX: 0002
+CONSTANT: kIOHIDElementFlagsRelativeMask HEX: 0004
+CONSTANT: kIOHIDElementFlagsWrapMask HEX: 0008
+CONSTANT: kIOHIDElementFlagsNonLinearMask HEX: 0010
+CONSTANT: kIOHIDElementFlagsNoPreferredMask HEX: 0020
+CONSTANT: kIOHIDElementFlagsNullStateMask HEX: 0040
+CONSTANT: kIOHIDElementFlagsVolativeMask HEX: 0080
+CONSTANT: kIOHIDElementFlagsBufferedByteMask HEX: 0100
+
+CONSTANT: kIOHIDValueScaleTypeCalibrated 0
+CONSTANT: kIOHIDValueScaleTypePhysical 1
+
+CONSTANT: kIOHIDTransactionDirectionTypeInput 0
+CONSTANT: kIOHIDTransactionDirectionTypeOutput 1
+
+CONSTANT: kIOHIDTransactionOptionDefaultOutputValue 1
TYPEDEF: ptrdiff_t IOHIDElementCookie
TYPEDEF: int IOHIDElementType
when
>>
-: kIOKitBuildVersionKey "IOKitBuildVersion" ; inline
-: kIOKitDiagnosticsKey "IOKitDiagnostics" ; inline
+CONSTANT: kIOKitBuildVersionKey "IOKitBuildVersion"
+CONSTANT: kIOKitDiagnosticsKey "IOKitDiagnostics"
-: kIORegistryPlanesKey "IORegistryPlanes" ; inline
-: kIOCatalogueKey "IOCatalogue" ; inline
+CONSTANT: kIORegistryPlanesKey "IORegistryPlanes"
+CONSTANT: kIOCatalogueKey "IOCatalogue"
-: kIOServicePlane "IOService" ; inline
-: kIOPowerPlane "IOPower" ; inline
-: kIODeviceTreePlane "IODeviceTree" ; inline
-: kIOAudioPlane "IOAudio" ; inline
-: kIOFireWirePlane "IOFireWire" ; inline
-: kIOUSBPlane "IOUSB" ; inline
+CONSTANT: kIOServicePlane "IOService"
+CONSTANT: kIOPowerPlane "IOPower"
+CONSTANT: kIODeviceTreePlane "IODeviceTree"
+CONSTANT: kIOAudioPlane "IOAudio"
+CONSTANT: kIOFireWirePlane "IOFireWire"
+CONSTANT: kIOUSBPlane "IOUSB"
-: kIOServiceClass "IOService" ; inline
+CONSTANT: kIOServiceClass "IOService"
-: kIOResourcesClass "IOResources" ; inline
+CONSTANT: kIOResourcesClass "IOResources"
-: kIOClassKey "IOClass" ; inline
-: kIOProbeScoreKey "IOProbeScore" ; inline
-: kIOKitDebugKey "IOKitDebug" ; inline
+CONSTANT: kIOClassKey "IOClass"
+CONSTANT: kIOProbeScoreKey "IOProbeScore"
+CONSTANT: kIOKitDebugKey "IOKitDebug"
-: kIOProviderClassKey "IOProviderClass" ; inline
-: kIONameMatchKey "IONameMatch" ; inline
-: kIOPropertyMatchKey "IOPropertyMatch" ; inline
-: kIOPathMatchKey "IOPathMatch" ; inline
-: kIOLocationMatchKey "IOLocationMatch" ; inline
-: kIOParentMatchKey "IOParentMatch" ; inline
-: kIOResourceMatchKey "IOResourceMatch" ; inline
-: kIOMatchedServiceCountKey "IOMatchedServiceCountMatch" ; inline
+CONSTANT: kIOProviderClassKey "IOProviderClass"
+CONSTANT: kIONameMatchKey "IONameMatch"
+CONSTANT: kIOPropertyMatchKey "IOPropertyMatch"
+CONSTANT: kIOPathMatchKey "IOPathMatch"
+CONSTANT: kIOLocationMatchKey "IOLocationMatch"
+CONSTANT: kIOParentMatchKey "IOParentMatch"
+CONSTANT: kIOResourceMatchKey "IOResourceMatch"
+CONSTANT: kIOMatchedServiceCountKey "IOMatchedServiceCountMatch"
-: kIONameMatchedKey "IONameMatched" ; inline
+CONSTANT: kIONameMatchedKey "IONameMatched"
-: kIOMatchCategoryKey "IOMatchCategory" ; inline
-: kIODefaultMatchCategoryKey "IODefaultMatchCategory" ; inline
+CONSTANT: kIOMatchCategoryKey "IOMatchCategory"
+CONSTANT: kIODefaultMatchCategoryKey "IODefaultMatchCategory"
-: kIOUserClientClassKey "IOUserClientClass" ; inline
+CONSTANT: kIOUserClientClassKey "IOUserClientClass"
-: kIOUserClientCrossEndianKey "IOUserClientCrossEndian" ; inline
-: kIOUserClientCrossEndianCompatibleKey "IOUserClientCrossEndianCompatible" ; inline
-: kIOUserClientSharedInstanceKey "IOUserClientSharedInstance" ; inline
+CONSTANT: kIOUserClientCrossEndianKey "IOUserClientCrossEndian"
+CONSTANT: kIOUserClientCrossEndianCompatibleKey "IOUserClientCrossEndianCompatible"
+CONSTANT: kIOUserClientSharedInstanceKey "IOUserClientSharedInstance"
-: kIOPublishNotification "IOServicePublish" ; inline
-: kIOFirstPublishNotification "IOServiceFirstPublish" ; inline
-: kIOMatchedNotification "IOServiceMatched" ; inline
-: kIOFirstMatchNotification "IOServiceFirstMatch" ; inline
-: kIOTerminatedNotification "IOServiceTerminate" ; inline
+CONSTANT: kIOPublishNotification "IOServicePublish"
+CONSTANT: kIOFirstPublishNotification "IOServiceFirstPublish"
+CONSTANT: kIOMatchedNotification "IOServiceMatched"
+CONSTANT: kIOFirstMatchNotification "IOServiceFirstMatch"
+CONSTANT: kIOTerminatedNotification "IOServiceTerminate"
-: kIOGeneralInterest "IOGeneralInterest" ; inline
-: kIOBusyInterest "IOBusyInterest" ; inline
-: kIOAppPowerStateInterest "IOAppPowerStateInterest" ; inline
-: kIOPriorityPowerStateInterest "IOPriorityPowerStateInterest" ; inline
+CONSTANT: kIOGeneralInterest "IOGeneralInterest"
+CONSTANT: kIOBusyInterest "IOBusyInterest"
+CONSTANT: kIOAppPowerStateInterest "IOAppPowerStateInterest"
+CONSTANT: kIOPriorityPowerStateInterest "IOPriorityPowerStateInterest"
-: kIOPlatformDeviceMessageKey "IOPlatformDeviceMessage" ; inline
+CONSTANT: kIOPlatformDeviceMessageKey "IOPlatformDeviceMessage"
-: kIOCFPlugInTypesKey "IOCFPlugInTypes" ; inline
+CONSTANT: kIOCFPlugInTypesKey "IOCFPlugInTypes"
-: kIOCommandPoolSizeKey "IOCommandPoolSize" ; inline
+CONSTANT: kIOCommandPoolSizeKey "IOCommandPoolSize"
-: kIOMaximumBlockCountReadKey "IOMaximumBlockCountRead" ; inline
-: kIOMaximumBlockCountWriteKey "IOMaximumBlockCountWrite" ; inline
-: kIOMaximumByteCountReadKey "IOMaximumByteCountRead" ; inline
-: kIOMaximumByteCountWriteKey "IOMaximumByteCountWrite" ; inline
-: kIOMaximumSegmentCountReadKey "IOMaximumSegmentCountRead" ; inline
-: kIOMaximumSegmentCountWriteKey "IOMaximumSegmentCountWrite" ; inline
-: kIOMaximumSegmentByteCountReadKey "IOMaximumSegmentByteCountRead" ; inline
-: kIOMaximumSegmentByteCountWriteKey "IOMaximumSegmentByteCountWrite" ; inline
-: kIOMinimumSegmentAlignmentByteCountKey "IOMinimumSegmentAlignmentByteCount" ; inline
-: kIOMaximumSegmentAddressableBitCountKey "IOMaximumSegmentAddressableBitCount" ; inline
+CONSTANT: kIOMaximumBlockCountReadKey "IOMaximumBlockCountRead"
+CONSTANT: kIOMaximumBlockCountWriteKey "IOMaximumBlockCountWrite"
+CONSTANT: kIOMaximumByteCountReadKey "IOMaximumByteCountRead"
+CONSTANT: kIOMaximumByteCountWriteKey "IOMaximumByteCountWrite"
+CONSTANT: kIOMaximumSegmentCountReadKey "IOMaximumSegmentCountRead"
+CONSTANT: kIOMaximumSegmentCountWriteKey "IOMaximumSegmentCountWrite"
+CONSTANT: kIOMaximumSegmentByteCountReadKey "IOMaximumSegmentByteCountRead"
+CONSTANT: kIOMaximumSegmentByteCountWriteKey "IOMaximumSegmentByteCountWrite"
+CONSTANT: kIOMinimumSegmentAlignmentByteCountKey "IOMinimumSegmentAlignmentByteCount"
+CONSTANT: kIOMaximumSegmentAddressableBitCountKey "IOMaximumSegmentAddressableBitCount"
-: kIOIconKey "IOIcon" ; inline
-: kIOBundleResourceFileKey "IOBundleResourceFile" ; inline
+CONSTANT: kIOIconKey "IOIcon"
+CONSTANT: kIOBundleResourceFileKey "IOBundleResourceFile"
-: kIOBusBadgeKey "IOBusBadge" ; inline
-: kIODeviceIconKey "IODeviceIcon" ; inline
+CONSTANT: kIOBusBadgeKey "IOBusBadge"
+CONSTANT: kIODeviceIconKey "IODeviceIcon"
-: kIOPlatformSerialNumberKey "IOPlatformSerialNumber" ; inline
+CONSTANT: kIOPlatformSerialNumberKey "IOPlatformSerialNumber"
-: kIOPlatformUUIDKey "IOPlatformUUID" ; inline
+CONSTANT: kIOPlatformUUIDKey "IOPlatformUUID"
-: kIONVRAMDeletePropertyKey "IONVRAM-DELETE-PROPERTY" ; inline
-: kIODTNVRAMPanicInfoKey "aapl,panic-info" ; inline
+CONSTANT: kIONVRAMDeletePropertyKey "IONVRAM-DELETE-PROPERTY"
+CONSTANT: kIODTNVRAMPanicInfoKey "aapl,panic-info"
-: kIOBootDeviceKey "IOBootDevice" ; inline
-: kIOBootDevicePathKey "IOBootDevicePath" ; inline
-: kIOBootDeviceSizeKey "IOBootDeviceSize" ; inline
+CONSTANT: kIOBootDeviceKey "IOBootDevice"
+CONSTANT: kIOBootDevicePathKey "IOBootDevicePath"
+CONSTANT: kIOBootDeviceSizeKey "IOBootDeviceSize"
-: kOSBuildVersionKey "OS Build Version" ; inline
+CONSTANT: kOSBuildVersionKey "OS Build Version"
-: kNilOptions 0 ; inline
+CONSTANT: kNilOptions 0
TYPEDEF: uint mach_port_t
TYPEDEF: int kern_return_t
TYPEDEF: uint IOOptionBits
-: MACH_PORT_NULL 0 ; inline
-: KERN_SUCCESS 0 ; inline
+CONSTANT: MACH_PORT_NULL 0
+CONSTANT: KERN_SUCCESS 0
FUNCTION: IOReturn IOMasterPort ( mach_port_t bootstrap, mach_port_t* master ) ;
! 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> irc-profile
\r
: write-color ( str color -- )\r
foreground associate format ;\r
-: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;\r
-: dark-green T{ rgba f 0.0 0.5 0.0 1 } ;\r
-: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ;\r
+CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }\r
+CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }\r
+CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }\r
\r
: dot-or-parens ( string -- string )\r
[ "." ]\r
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 ;
: 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 } } }
{ 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 } } }
- } ;
+ }
: <indicator-gadget> ( color -- indicator )
indicator-polygon <polygon-gadget> ;
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 } } }
{ 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 ;
set-alien-float alien-float
} ;
-: trivial-defs
+: trivial-defs ( -- seq )
{
[ drop ] [ 2array ]
[ bitand ]
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 ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax multiline ;
+USING: help.markup help.syntax kernel multiline ;
IN: literals
HELP: $
{ $syntax "$ word" }
{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
-{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." }
+{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
{ $examples
{ $example <"
USING: kernel literals prettyprint ;
IN: scratchpad
-<< : five 5 ; >>
+CONSTANT: five 5
{ $ five } .
"> "{ 5 }" }
HELP: $[
{ $syntax "$[ code ]" }
{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
-{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." }
+{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
{ $examples
{ $example <"
IN: literals.tests
<<
-: five 5 ;
-: seven-eleven 7 11 ;
: six-six-six 6 6 6 ;
>>
+: five 5 ;
+: seven-eleven 7 11 ;
+
[ { 5 } ] [ { $ five } ] unit-test
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
! (c) Joe Groff, see license for details
-USING: continuations kernel parser words quotations vectors ;
+USING: accessors continuations kernel parser words quotations vectors ;
IN: literals
-: $ scan-word [ execute ] curry with-datastack >vector ; parsing
+: $ scan-word [ def>> call ] curry with-datastack >vector ; parsing
: $[ \ ] parse-until >quotation with-datastack >vector ; parsing
! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar io.directories io.encodings.utf8
io.files io.launcher mason.child mason.cleanup mason.common
-mason.email mason.help mason.release mason.report namespaces
-prettyprint ;
+mason.help mason.release mason.report namespaces prettyprint ;
IN: mason.build
: create-build-dir ( -- )
build-child
upload-help
release
- email-report
cleanup ;
MAIN: build
\ No newline at end of file
USING: accessors arrays calendar combinators.short-circuit
continuations debugger http.client io.directories io.files
io.launcher io.pathnames kernel make mason.common mason.config
-mason.platform mason.report namespaces sequences ;
+mason.platform mason.report mason.email namespaces sequences ;
IN: mason.child
: make-cmd ( -- args )
build-clean? status-clean status-dirty ? return-with
] callcc1
- status set ;
\ No newline at end of file
+ status set
+ email-report ;
\ No newline at end of file
: ?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
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: bootstrap.image continuations debugger fry
-io.directories io.directories.hierarchy io.files io.launcher
+USING: bootstrap.image continuations debugger fry io.directories
+io.directories.hierarchy io.encodings.ascii io.files io.launcher
kernel mason.common namespaces sequences ;
FROM: mason.config => target-os ;
IN: mason.release.tidy
: common-files ( -- seq )
+ "build-support/cleanup" ascii file-lines
images [ boot-image-name ] map
- {
- "vm"
- "temp"
- "logs"
- ".git"
- ".gitignore"
- "Makefile"
- "unmaintained"
- "unfinished"
- "build-support"
- }
append ;
: remove-common-files ( -- )
! http://www.rskey.org/gamma.htm "Lanczos Approximation"
! n=6: error ~ 3 x 10^-11
-: gamma-g6 5.15 ; inline
+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 ;
--- /dev/null
+Jason W. Merrill
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: math.derivatives
+
+ARTICLE: "math.derivatives" "Derivatives"
+"The " { $vocab-link "math.derivatives" } " vocabulary defines the derivative of many of the words in the " { $vocab-link "math" } " and " { $vocab-link "math.functions" } " vocabularies. The derivative for a word is given by a sequence of quotations stored in its " { $snippet "derivative" } " word property that give the partial derivative of the word with respect to each of its inputs."
+{ $see-also "math.derivatives.syntax" }
+;
+
+ABOUT: "math.derivatives"
--- /dev/null
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions math.derivatives.syntax
+ math.order math.parser summary accessors make combinators ;
+IN: math.derivatives
+
+ERROR: undefined-derivative point word ;
+M: undefined-derivative summary
+ [ dup "Derivative of " % word>> name>> %
+ " is undefined at " % point>> # "." % ]
+ "" make ;
+
+DERIVATIVE: + [ 2drop ] [ 2drop ]
+DERIVATIVE: - [ 2drop ] [ 2drop neg ]
+DERIVATIVE: * [ nip * ] [ drop * ]
+DERIVATIVE: / [ nip / ] [ sq / neg * ]
+! Conditional checks if the epsilon-part of the exponent is
+! 0 to avoid getting float answers for integer powers.
+DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ]
+ [ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ]
+
+DERIVATIVE: abs
+ [ 0 <=>
+ {
+ { +lt+ [ neg ] }
+ { +eq+ [ 0 \ abs undefined-derivative ] }
+ { +gt+ [ ] }
+ } case
+ ]
+
+DERIVATIVE: sqrt [ sqrt 2 * / ]
+
+DERIVATIVE: exp [ exp * ]
+DERIVATIVE: log [ / ]
+
+DERIVATIVE: sin [ cos * ]
+DERIVATIVE: cos [ sin neg * ]
+DERIVATIVE: tan [ sec sq * ]
+
+DERIVATIVE: sinh [ cosh * ]
+DERIVATIVE: cosh [ sinh * ]
+DERIVATIVE: tanh [ sech sq * ]
+
+DERIVATIVE: asin [ sq neg 1 + sqrt / ]
+DERIVATIVE: acos [ sq neg 1 + sqrt neg / ]
+DERIVATIVE: atan [ sq 1 + / ]
+
+DERIVATIVE: asinh [ sq 1 + sqrt / ]
+DERIVATIVE: acosh [ [ 1 + sqrt ] [ 1 - sqrt ] bi * / ]
+DERIVATIVE: atanh [ sq neg 1 + / ]
+
+DERIVATIVE: neg [ drop neg ]
+DERIVATIVE: recip [ sq recip neg * ]
--- /dev/null
+Jason W. Merrill
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: math.derivatives.syntax
+
+HELP: DERIVATIVE:
+{ $description "Defines the derivative of a word by setting its " { $snippet "derivative" } " word property. Reads a word followed by " { $snippet "n" } " quotations, giving the " { $snippet "n" } " partial derivatives of the word with respect to each of its arguments successively. Each quotation should take " { $snippet "n + 1" } " inputs, where the first input is an increment and the last " { $snippet "n" } " inputs are the point at which to evaluate the derivative. The derivative should be a linear function of the increment, and should have the same number of outputs as the original word." }
+{ $examples
+ { $unchecked-example "USING: math math.functions math.derivatives.syntax ;"
+ "DERIVATIVE: sin [ cos * ]"
+ "DERIVATIVE: * [ nip * ] [ drop * ]" "" }
+} ;
+
+ARTICLE: "math.derivatives.syntax" "Derivative Syntax"
+"The " { $vocab-link "math.derivatives.syntax" } " vocabulary provides the " { $link POSTPONE: DERIVATIVE: } " syntax for specifying the derivative of a word."
+;
+
+ABOUT: "math.derivatives.syntax"
--- /dev/null
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel parser words effects accessors sequences
+ math.ranges ;
+
+IN: math.derivatives.syntax
+
+: DERIVATIVE: scan-object dup stack-effect in>> length [1,b]
+ [ drop scan-object ] map
+ "derivative" set-word-prop ; parsing
\ No newline at end of file
--- /dev/null
+Jason W. Merrill
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel words math math.functions math.derivatives.syntax ;
+IN: math.dual
+
+HELP: <dual>
+{ $values
+ { "ordinary-part" real } { "epsilon-part" real }
+ { "dual" dual number }
+}
+{ $description "Creates a dual number from its ordinary and epsilon parts." } ;
+
+HELP: define-dual
+{ $values
+ { "word" word }
+}
+{ $description "Defines a word " { $snippet "d[word]" } " in the " { $vocab-link "math.dual" } " vocabulary that operates on dual numbers." }
+{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } "." } ;
+
+{ define-dual dual-op POSTPONE: DERIVATIVE: } related-words
+
+HELP: dual
+{ $class-description "The class of dual numbers with non-zero epsilon part." } ;
+
+HELP: dual-op
+{ $values
+ { "word" word }
+}
+{ $description "Similar to " { $link execute } ", but promotes word to operate on duals." }
+{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } ". Once a derivative has been defined for a word, dual-op makes it easy to extend the definition to dual numbers." }
+{ $examples
+ { $unchecked-example "USING: math math.dual math.derivatives.syntax math.functions ;"
+ "DERIVATIVE: sin [ cos * ]"
+ "M: dual sin \\sin dual-op ;" "" }
+ { $unchecked-example "USING: math math.dual math.derivatives.syntax ;"
+ "DERIVATIVE: * [ drop ] [ nip ]"
+ ": d* ( x y -- x*y ) \ * dual-op ;" "" }
+} ;
+
+HELP: unpack-dual
+{ $values
+ { "dual" dual }
+ { "ordinary-part" number } { "epsilon-part" number }
+}
+{ $description "Extracts the ordinary and epsilon part of a dual number." } ;
+
+ARTICLE: "math.dual" "Dual Numbers"
+"The " { $vocab-link "math.dual" } " vocabulary implements dual numbers, along with arithmetic methods for working with them. Many of the functions in " { $vocab-link "math.functions" } " are extended to work with dual numbers."
+$nl
+"Dual numbers are ordered pairs " { $snippet "<o,e>"} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "<o1,e1>*<o2,e2> = <o1*o2,e1*o2 + e2*o1>" } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f(<o1,e1>) = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "."
+;
+
+ABOUT: "math.dual"
--- /dev/null
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.dual kernel accessors math math.functions
+ math.constants ;
+IN: math.dual.tests
+
+[ 0.0 1.0 ] [ 0 1 <dual> dsin unpack-dual ] unit-test
+[ 1.0 0.0 ] [ 0 1 <dual> dcos unpack-dual ] unit-test
+[ 3 5 ] [ 1 5 <dual> 2 d+ unpack-dual ] unit-test
+[ 0 -1 ] [ 1 5 <dual> 1 6 <dual> d- unpack-dual ] unit-test
+[ 2 1 ] [ 2 3 <dual> 1 -1 <dual> d* unpack-dual ] unit-test
+[ 1/2 -1/4 ] [ 2 1 <dual> 1 swap d/ unpack-dual ] unit-test
+[ 2 ] [ 1 1 <dual> 2 d^ epsilon-part>> ] unit-test
+[ 2.0 .25 ] [ 4 1 <dual> dsqrt unpack-dual ] unit-test
+[ 2 -1 ] [ -2 1 <dual> dabs unpack-dual ] unit-test
+[ -2 -1 ] [ 2 1 <dual> dneg unpack-dual ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jason W. Merrill.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions math.derivatives accessors
+ macros generic compiler.units words effects vocabs
+ sequences arrays assocs generalizations fry make
+ combinators.smart help help.markup ;
+
+IN: math.dual
+
+TUPLE: dual ordinary-part epsilon-part ;
+
+C: <dual> dual
+
+! Ordinary numbers implement the dual protocol by returning
+! themselves as the ordinary part, and 0 as the epsilon part.
+M: number ordinary-part>> ;
+
+M: number epsilon-part>> drop 0 ;
+
+: unpack-dual ( dual -- ordinary-part epsilon-part )
+ [ ordinary-part>> ] [ epsilon-part>> ] bi ;
+
+<PRIVATE
+
+: input-length ( word -- n ) stack-effect in>> length ;
+
+MACRO: ordinary-op ( word -- o )
+ [ input-length ] keep
+ '[ [ ordinary-part>> ] _ napply _ execute ] ;
+
+! Takes N dual numbers <o1,e1> <o2,e2> ... <oN,eN> and weaves
+! their ordinary and epsilon parts to produce
+! e1 o1 o2 ... oN e2 o1 o2 ... oN ... eN o1 o2 ... oN
+! This allows a set of partial derivatives each to be evaluated
+! at the same point.
+MACRO: duals>nweave ( n -- )
+ dup dup dup
+ '[
+ [ [ epsilon-part>> ] _ napply ]
+ _ nkeep
+ [ ordinary-part>> ] _ napply
+ _ nweave
+ ] ;
+
+MACRO: chain-rule ( word -- e )
+ [ input-length '[ _ duals>nweave ] ]
+ [ "derivative" word-prop ]
+ [ input-length 1+ '[ _ nspread ] ]
+ tri
+ '[ [ @ _ @ ] sum-outputs ] ;
+
+: set-dual-help ( word dword -- )
+ [ swap
+ [ stack-effect [ in>> ] [ out>> ] bi append
+ [ dual ] { } map>assoc { $values } prepend
+ ]
+ [ [ { $description } % "Version of " ,
+ { $link } swap suffix ,
+ " extended to work on dual numbers." , ]
+ { } make
+ ]
+ bi* 2array
+ ] keep set-word-help ;
+
+PRIVATE>
+
+MACRO: dual-op ( word -- )
+ [ '[ _ ordinary-op ] ]
+ [ input-length '[ _ nkeep ] ]
+ [ '[ _ chain-rule ] ]
+ tri
+ '[ _ @ @ <dual> ] ;
+
+: define-dual ( word -- )
+ dup name>> "d" prepend "math.dual" create
+ [ [ stack-effect ] dip set-stack-effect ]
+ [ set-dual-help ]
+ [ swap '[ _ dual-op ] define ]
+ 2tri ;
+
+! Specialize math functions to operate on dual numbers.
+[ all-words [ "derivative" word-prop ] filter
+ [ define-dual ] each ] with-compilation-unit
\ No newline at end of file
math.order math.geometry.rect ;
IN: maze
-: line-width 8 ;
+CONSTANT: line-width 8
SYMBOL: visited
sequences kernel sequences parser memoize ;
IN: minneapolis-talk
-: minneapolis-slides
+CONSTANT: minneapolis-slides
{
{ $slide "What is Factor?"
"Dynamically typed, stack language"
"Mailing list: factor-talk@lists.sf.net"
}
{ $slide "Questions?" }
-} ;
+}
: minneapolis-talk ( -- ) minneapolis-slides slides-window ;
+++ /dev/null
-- how to create a small module\r
-- editor integration\r
-- presentations\r
-- module system\r
-- copy and paste factoring, inverse\r
-- help system\r
-- tetris\r
-- memoization\r
-- editing inspector demo\r
-- dynamic scope, lexical scope\r
-\r
-Factor: contradictions?\r
------------------------\r
-\r
-Have our cake and eat it too\r
-\r
-Research -vs- practical\r
-High level -vs- fast\r
-Interactive -vs- deployment\r
-\r
-Factor from 10,000 feet\r
------------------------\r
-\r
-word: named function\r
-vocabulary: module\r
-quotation: anonymous function\r
-classes, objects, etc.\r
-\r
-The stack\r
----------\r
-\r
-- Stack -vs- applicative\r
-- Pass by reference, dynamically typed\r
-- Stack languages: you can omit names where they're not needed\r
-- More compositional style\r
-- If you need to name things for clarity, you can:\r
- lexical vars, dynamic vars, sequences, assocs, objects...\r
-\r
-Functional programming\r
-----------------------\r
-\r
-Quotations\r
-Curry\r
-Continuations\r
-\r
-Object-oriented programming\r
----------------------------\r
-\r
-Generic words: sort of like open classes\r
-Tuple reshaping\r
-Editing inspector\r
-\r
-Meta programming\r
-----------------\r
-\r
-Simple, orthogonal core\r
-\r
-Why use a stack at all?\r
------------------------\r
-\r
-Nice idioms: 10 days ago\r
-Copy and paste factoring\r
-Easy meta-programming\r
-Sequence operations correspond to functional operations:\r
-- curry is adding at the front\r
-- compose is append\r
-\r
-UI\r
---\r
-\r
-Written in Factor\r
-renders with OpenGL\r
-Windows, X11, Cocoa backends\r
-You can call Windows, X11, Cocoa APIs directly\r
-OpenGL 2.1 shaders, OpenAL 3D audio...\r
-\r
-Tools\r
------\r
-\r
-Edit\r
-Usages\r
-Profiler\r
-Easy to make your own tools\r
-\r
-Implementation\r
---------------\r
-\r
-Two compilers\r
-Generational garbage collector\r
-Non-blocking I/O\r
-\r
-Hands on\r
---------\r
-\r
-Community\r
----------\r
-\r
-Factor started in 2003\r
-About a dozen contributors\r
-Handful of "core contributors"\r
-Web site: http://factorcode.org\r
-IRC: #concatenative on irc.freenode.net\r
-Mailing list: factor-talk@lists.sf.net\r
-\r
-C library interface\r
--------------------\r
-\r
-Efficient\r
-No need to write C code\r
-Supports floats, structs, unions, ...\r
-Function pointers, callbacks\r
-Here is an example\r
-\r
-TerminateProcess\r
-\r
-process-handle TerminateProcess\r
TUPLE: nehe2-gadget < gadget ;
-: width 256 ;
-: height 256 ;
+CONSTANT: width 256
+CONSTANT: height 256
: <nehe2-gadget> ( -- gadget )
nehe2-gadget new-gadget ;
TUPLE: nehe3-gadget < gadget ;
-: width 256 ;
-: height 256 ;
+CONSTANT: width 256
+CONSTANT: height 256
: <nehe3-gadget> ( -- gadget )
nehe3-gadget new-gadget ;
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
-: width 256 ;
-: height 256 ;
+CONSTANT: width 256
+CONSTANT: height 256
: redraw-interval ( -- dt ) 10 milliseconds ;
: <nehe4-gadget> ( -- gadget )
IN: nehe.5\r
\r
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;\r
-: width 256 ;\r
-: height 256 ;\r
+CONSTANT: width 256\r
+CONSTANT: height 256\r
: redraw-interval ( -- dt ) 10 milliseconds ;\r
\r
: <nehe5-gadget> ( -- gadget )\r
IN: opengl.demo-support
: FOV ( -- x ) 2.0 sqrt 1+ ; inline
-: MOUSE-MOTION-SCALE 0.5 ; inline
-: KEY-ROTATE-STEP 10.0 ; inline
+CONSTANT: MOUSE-MOTION-SCALE 0.5
+CONSTANT: KEY-ROTATE-STEP 10.0
SYMBOL: last-drag-loc
: $tetris ( element -- )
drop [ <default-tetris> <tetris-gadget> gadget. ] ($block) ;
-: otug-slides
+CONSTANT: otug-slides
{
{ $slide "Factor!"
{ $url "http://factorcode.org" }
"Factor has many cool things that I didn't talk about"
"Questions?"
}
-} ;
+}
: otug-talk ( -- ) otug-slides slides-window ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types assocs combinators destructors
-kernel math math.bitwise math.parser sequences summary system
-vocabs.loader ;
-IN: serial
-
-TUPLE: serial stream path baud
- termios iflag oflag cflag lflag ;
-
-ERROR: invalid-baud baud ;
-M: invalid-baud summary ( invalid-baud -- string )
- "Baud rate "
- swap baud>> number>string
- " not supported" 3append ;
-
-HOOK: lookup-baud os ( m -- n )
-HOOK: open-serial os ( serial -- serial' )
-M: serial dispose ( serial -- ) stream>> dispose ;
-
-{
- { [ os unix? ] [ "serial.unix" ] }
- { [ os windows? ] [ "serial.windows" ] }
-} cond require
+++ /dev/null
-Serial port library
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math.bitwise sequences system serial ;
-IN: serial.unix
-
-M: bsd lookup-baud ( m -- n )
- dup {
- 0 50 75 110 134 150 200 300 600 1200 1800 2400 4800
- 7200 9600 14400 19200 28800 38400 57600 76800 115200
- 230400 460800 921600
- } member? [ invalid-baud ] unless ;
-
-: TCSANOW 0 ; inline
-: TCSADRAIN 1 ; inline
-: TCSAFLUSH 2 ; inline
-: TCSASOFT HEX: 10 ; inline
-
-: TCIFLUSH 1 ; inline
-: TCOFLUSH 2 ; inline
-: TCIOFLUSH 3 ; inline
-: TCOOFF 1 ; inline
-: TCOON 2 ; inline
-: TCIOFF 3 ; inline
-: TCION 4 ; inline
-
-! iflags
-: IGNBRK HEX: 00000001 ; inline
-: BRKINT HEX: 00000002 ; inline
-: IGNPAR HEX: 00000004 ; inline
-: PARMRK HEX: 00000008 ; inline
-: INPCK HEX: 00000010 ; inline
-: ISTRIP HEX: 00000020 ; inline
-: INLCR HEX: 00000040 ; inline
-: IGNCR HEX: 00000080 ; inline
-: ICRNL HEX: 00000100 ; inline
-: IXON HEX: 00000200 ; inline
-: IXOFF HEX: 00000400 ; inline
-: IXANY HEX: 00000800 ; inline
-: IMAXBEL HEX: 00002000 ; inline
-: IUTF8 HEX: 00004000 ; inline
-
-! oflags
-: OPOST HEX: 00000001 ; inline
-: ONLCR HEX: 00000002 ; inline
-: OXTABS HEX: 00000004 ; inline
-: ONOEOT HEX: 00000008 ; inline
-
-! cflags
-: CIGNORE HEX: 00000001 ; inline
-: CSIZE HEX: 00000300 ; inline
-: CS5 HEX: 00000000 ; inline
-: CS6 HEX: 00000100 ; inline
-: CS7 HEX: 00000200 ; inline
-: CS8 HEX: 00000300 ; inline
-: CSTOPB HEX: 00000400 ; inline
-: CREAD HEX: 00000800 ; inline
-: PARENB HEX: 00001000 ; inline
-: PARODD HEX: 00002000 ; inline
-: HUPCL HEX: 00004000 ; inline
-: CLOCAL HEX: 00008000 ; inline
-: CCTS_OFLOW HEX: 00010000 ; inline
-: CRTS_IFLOW HEX: 00020000 ; inline
-: CRTSCTS { CCTS_OFLOW CRTS_IFLOW } flags ; inline
-: CDTR_IFLOW HEX: 00040000 ; inline
-: CDSR_OFLOW HEX: 00080000 ; inline
-: CCAR_OFLOW HEX: 00100000 ; inline
-: MDMBUF HEX: 00100000 ; inline
-
-! lflags
-: ECHOKE HEX: 00000001 ; inline
-: ECHOE HEX: 00000002 ; inline
-: ECHOK HEX: 00000004 ; inline
-: ECHO HEX: 00000008 ; inline
-: ECHONL HEX: 00000010 ; inline
-: ECHOPRT HEX: 00000020 ; inline
-: ECHOCTL HEX: 00000040 ; inline
-: ISIG HEX: 00000080 ; inline
-: ICANON HEX: 00000100 ; inline
-: ALTWERASE HEX: 00000200 ; inline
-: IEXTEN HEX: 00000400 ; inline
-: EXTPROC HEX: 00000800 ; inline
-: TOSTOP HEX: 00400000 ; inline
-: FLUSHO HEX: 00800000 ; inline
-: NOKERNINFO HEX: 02000000 ; inline
-: PENDIN HEX: 20000000 ; inline
-: NOFLSH HEX: 80000000 ; inline
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs alien.syntax kernel serial system unix ;
-IN: serial.unix
-
-: TCSANOW 0 ; inline
-: TCSADRAIN 1 ; inline
-: TCSAFLUSH 2 ; inline
-
-: TCIFLUSH 0 ; inline
-: TCOFLUSH 1 ; inline
-: TCIOFLUSH 2 ; inline
-
-: TCOOFF 0 ; inline
-: TCOON 1 ; inline
-: TCIOFF 2 ; inline
-: TCION 3 ; inline
-
-! iflag
-: IGNBRK OCT: 0000001 ; inline
-: BRKINT OCT: 0000002 ; inline
-: IGNPAR OCT: 0000004 ; inline
-: PARMRK OCT: 0000010 ; inline
-: INPCK OCT: 0000020 ; inline
-: ISTRIP OCT: 0000040 ; inline
-: INLCR OCT: 0000100 ; inline
-: IGNCR OCT: 0000200 ; inline
-: ICRNL OCT: 0000400 ; inline
-: IUCLC OCT: 0001000 ; inline
-: IXON OCT: 0002000 ; inline
-: IXANY OCT: 0004000 ; inline
-: IXOFF OCT: 0010000 ; inline
-: IMAXBEL OCT: 0020000 ; inline
-: IUTF8 OCT: 0040000 ; inline
-
-! oflag
-: OPOST OCT: 0000001 ; inline
-: OLCUC OCT: 0000002 ; inline
-: ONLCR OCT: 0000004 ; inline
-: OCRNL OCT: 0000010 ; inline
-: ONOCR OCT: 0000020 ; inline
-: ONLRET OCT: 0000040 ; inline
-: OFILL OCT: 0000100 ; inline
-: OFDEL OCT: 0000200 ; inline
-: NLDLY OCT: 0000400 ; inline
-: NL0 OCT: 0000000 ; inline
-: NL1 OCT: 0000400 ; inline
-: CRDLY OCT: 0003000 ; inline
-: CR0 OCT: 0000000 ; inline
-: CR1 OCT: 0001000 ; inline
-: CR2 OCT: 0002000 ; inline
-: CR3 OCT: 0003000 ; inline
-: TABDLY OCT: 0014000 ; inline
-: TAB0 OCT: 0000000 ; inline
-: TAB1 OCT: 0004000 ; inline
-: TAB2 OCT: 0010000 ; inline
-: TAB3 OCT: 0014000 ; inline
-: BSDLY OCT: 0020000 ; inline
-: BS0 OCT: 0000000 ; inline
-: BS1 OCT: 0020000 ; inline
-: FFDLY OCT: 0100000 ; inline
-: FF0 OCT: 0000000 ; inline
-: FF1 OCT: 0100000 ; inline
-
-! cflags
-: CSIZE OCT: 0000060 ; inline
-: CS5 OCT: 0000000 ; inline
-: CS6 OCT: 0000020 ; inline
-: CS7 OCT: 0000040 ; inline
-: CS8 OCT: 0000060 ; inline
-: CSTOPB OCT: 0000100 ; inline
-: CREAD OCT: 0000200 ; inline
-: PARENB OCT: 0000400 ; inline
-: PARODD OCT: 0001000 ; inline
-: HUPCL OCT: 0002000 ; inline
-: CLOCAL OCT: 0004000 ; inline
-: CIBAUD OCT: 002003600000 ; inline
-: CRTSCTS OCT: 020000000000 ; inline
-
-! lflags
-: ISIG OCT: 0000001 ; inline
-: ICANON OCT: 0000002 ; inline
-: XCASE OCT: 0000004 ; inline
-: ECHO OCT: 0000010 ; inline
-: ECHOE OCT: 0000020 ; inline
-: ECHOK OCT: 0000040 ; inline
-: ECHONL OCT: 0000100 ; inline
-: NOFLSH OCT: 0000200 ; inline
-: TOSTOP OCT: 0000400 ; inline
-: ECHOCTL OCT: 0001000 ; inline
-: ECHOPRT OCT: 0002000 ; inline
-: ECHOKE OCT: 0004000 ; inline
-: FLUSHO OCT: 0010000 ; inline
-: PENDIN OCT: 0040000 ; inline
-: IEXTEN OCT: 0100000 ; inline
-
-M: linux lookup-baud ( n -- n )
- dup H{
- { 0 OCT: 0000000 }
- { 50 OCT: 0000001 }
- { 75 OCT: 0000002 }
- { 110 OCT: 0000003 }
- { 134 OCT: 0000004 }
- { 150 OCT: 0000005 }
- { 200 OCT: 0000006 }
- { 300 OCT: 0000007 }
- { 600 OCT: 0000010 }
- { 1200 OCT: 0000011 }
- { 1800 OCT: 0000012 }
- { 2400 OCT: 0000013 }
- { 4800 OCT: 0000014 }
- { 9600 OCT: 0000015 }
- { 19200 OCT: 0000016 }
- { 38400 OCT: 0000017 }
- { 57600 OCT: 0010001 }
- { 115200 OCT: 0010002 }
- { 230400 OCT: 0010003 }
- { 460800 OCT: 0010004 }
- { 500000 OCT: 0010005 }
- { 576000 OCT: 0010006 }
- { 921600 OCT: 0010007 }
- { 1000000 OCT: 0010010 }
- { 1152000 OCT: 0010011 }
- { 1500000 OCT: 0010012 }
- { 2000000 OCT: 0010013 }
- { 2500000 OCT: 0010014 }
- { 3000000 OCT: 0010015 }
- { 3500000 OCT: 0010016 }
- { 4000000 OCT: 0010017 }
- } at* [ nip ] [ drop invalid-baud ] if ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences system ;
-IN: serial.unix.termios
-
-: NCCS 20 ; inline
-
-TYPEDEF: uint tcflag_t
-TYPEDEF: uchar cc_t
-TYPEDEF: uint speed_t
-
-C-STRUCT: termios
- { "tcflag_t" "iflag" } ! input mode flags
- { "tcflag_t" "oflag" } ! output mode flags
- { "tcflag_t" "cflag" } ! control mode flags
- { "tcflag_t" "lflag" } ! local mode flags
- { { "cc_t" NCCS } "cc" } ! control characters
- { "speed_t" "ispeed" } ! input speed
- { "speed_t" "ospeed" } ; ! output speed
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel system unix ;
-IN: serial.unix.termios
-
-: NCCS 32 ; inline
-
-TYPEDEF: uchar cc_t
-TYPEDEF: uint speed_t
-TYPEDEF: uint tcflag_t
-
-C-STRUCT: termios
- { "tcflag_t" "iflag" } ! input mode flags
- { "tcflag_t" "oflag" } ! output mode flags
- { "tcflag_t" "cflag" } ! control mode flags
- { "tcflag_t" "lflag" } ! local mode flags
- { "cc_t" "line" } ! line discipline
- { { "cc_t" NCCS } "cc" } ! control characters
- { "speed_t" "ispeed" } ! input speed
- { "speed_t" "ospeed" } ; ! output speed
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators system vocabs.loader ;
-IN: serial.unix.termios
-
-{
- { [ os linux? ] [ "serial.unix.termios.linux" ] }
- { [ os bsd? ] [ "serial.unix.termios.bsd" ] }
-} cond require
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.bitwise serial serial.unix ;
-IN: serial.unix
-
-: serial-obj ( -- obj )
- serial new
- "/dev/ttyS0" >>path
- 19200 >>baud
- { IGNPAR ICRNL } flags >>iflag
- { } flags >>oflag
- { CS8 CLOCAL CREAD } flags >>cflag
- { ICANON } flags >>lflag ;
-
-: serial-test ( -- serial )
- serial-obj
- open-serial
- dup get-termios >>termios
- dup configure-termios
- dup tciflush
- dup apply-termios ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.syntax combinators io.ports
-io.streams.duplex io.unix.backend system kernel math math.bitwise
-vocabs.loader unix serial serial.unix.termios ;
-IN: serial.unix
-
-<< {
- { [ os linux? ] [ "serial.unix.linux" ] }
- { [ os bsd? ] [ "serial.unix.bsd" ] }
-} cond require >>
-
-FUNCTION: speed_t cfgetispeed ( termios* t ) ;
-FUNCTION: speed_t cfgetospeed ( termios* t ) ;
-FUNCTION: int cfsetispeed ( termios* t, speed_t s ) ;
-FUNCTION: int cfsetospeed ( termios* t, speed_t s ) ;
-FUNCTION: int tcgetattr ( int i1, termios* t ) ;
-FUNCTION: int tcsetattr ( int i1, int i2, termios* t ) ;
-FUNCTION: int tcdrain ( int i1 ) ;
-FUNCTION: int tcflow ( int i1, int i2 ) ;
-FUNCTION: int tcflush ( int i1, int i2 ) ;
-FUNCTION: int tcsendbreak ( int i1, int i2 ) ;
-FUNCTION: void cfmakeraw ( termios* t ) ;
-FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
-
-: fd>duplex-stream ( fd -- duplex-stream )
- <fd> init-fd
- [ <input-port> ] [ <output-port> ] bi <duplex-stream> ;
-
-: open-rw ( path -- fd ) O_RDWR file-mode open-file ;
-: <file-rw> ( path -- stream ) open-rw fd>duplex-stream ;
-
-M: unix open-serial ( serial -- serial' )
- dup
- path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
- fd>duplex-stream >>stream ;
-
-: serial-fd ( serial -- fd )
- stream>> in>> handle>> fd>> ;
-
-: get-termios ( serial -- termios )
- serial-fd
- "termios" <c-object> [ tcgetattr io-error ] keep ;
-
-: configure-termios ( serial -- )
- dup termios>>
- {
- [ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ]
- [ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ]
- [
- [
- [ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor
- ] dip set-termios-cflag
- ]
- [ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ]
- } 2cleave ;
-
-: tciflush ( serial -- )
- serial-fd TCIFLUSH tcflush io-error ;
-
-: apply-termios ( serial -- )
- [ serial-fd TCSANOW ]
- [ termios>> ] bi tcsetattr io-error ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2009 Your name.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test serial.windows ;
-IN: serial.windows.tests
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.files.windows io.streams.duplex kernel math
-math.bitwise windows.kernel32 accessors alien.c-types
-windows io.files.windows fry locals continuations ;
-IN: serial.windows
-
-: <serial-stream> ( path encoding -- duplex )
- [ open-r/w dup ] dip <encoder-duplex> ;
-
-: get-comm-state ( duplex -- dcb )
- in>> handle>>
- "DCB" <c-object> tuck
- GetCommState win32-error=0/f ;
-
-: set-comm-state ( duplex dcb -- )
- [ in>> handle>> ] dip
- SetCommState win32-error=0/f ;
-
-:: with-comm-state ( duplex quot: ( dcb -- ) -- )
- duplex get-comm-state :> dcb
- dcb clone quot curry [ dcb set-comm-state ] recover ; inline
parser accessors colors ;
IN: slides
-: stylesheet
+CONSTANT: stylesheet
H{
{ default-span-style
H{
H{ { table-gap { 10 20 } } }
}
{ bullet "\u0000b7" }
- } ;
+ }
: $title ( string -- )
[ H{ { font "sans-serif" } { font-size 48 } } format ] ($block) ;
{ paused? initial: f }
{ running? initial: t } ;
-: default-width 10 ; inline
-: default-height 20 ; inline
+CONSTANT: default-width 10
+CONSTANT: default-height 20
: <tetris> ( width height -- tetris )
dupd <board> swap <piece-llist>
compiler.cfg.optimizer fry ;
IN: vpri-talk
-: vpri-slides
+CONSTANT: vpri-slides
{
{ $slide "Factor!"
{ $url "http://factorcode.org" }
"Factor has many cool things that I didn't talk about"
"Questions?"
}
-} ;
+}
: vpri-talk ( -- ) vpri-slides slides-window ;
first3 <result>
] 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
"similar_ok" [ similar-ok>> ] bool-param
nip ;
-: factor-id
- "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" ;
+CONSTANT: factor-id "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-"
: <search> ( query -- search )
search new
+++ /dev/null
-;;; factor.el --- Interacting with Factor within emacs
-;;
-;; Authors: Eduardo Cavazos <wayo.cavazos@gmail.com>
-;; Jose A Ortega Ruiz <jao@gnu.org>
-;; Keywords: languages
-
-;;; Commentary:
-
-;;; Quick setup:
-
-;; Add these lines to your .emacs file:
-;;
-;; (load-file "/scratch/repos/Factor/misc/factor.el")
-;; (setq factor-binary "/scratch/repos/Factor/factor")
-;; (setq factor-image "/scratch/repos/Factor/factor.image")
-;;
-;; Of course, you'll have to edit the directory paths for your system
-;; accordingly. Alternatively, put this file in your load-path and use
-;;
-;; (require 'factor)
-;;
-;; instead of load-file.
-;;
-;; That's all you have to do to "install" factor.el on your
-;; system. Whenever you edit a factor file, Emacs will know to switch
-;; to Factor mode.
-;;
-;; For further customization options,
-;; M-x customize-group RET factor
-;;
-;; To start a Factor listener inside Emacs,
-;; M-x run-factor
-
-;;; Requirements:
-
-(require 'font-lock)
-(require 'comint)
-(require 'view)
-(require 'ring)
-
-;;; Customization:
-
-(defgroup factor nil
- "Factor mode"
- :group 'languages)
-
-(defcustom factor-default-indent-width 4
- "Default indentantion width for factor-mode.
-
-This value will be used for the local variable
-`factor-indent-width' in new factor buffers. For existing code,
-we first check if `factor-indent-width' is set explicitly in a
-local variable section or line (e.g. '! -*- factor-indent-witdth: 2 -*-').
-If that's not the case, `factor-mode' tries to infer its correct
-value from the existing code in the buffer."
- :type 'integer
- :group 'factor)
-
-(defcustom factor-binary "~/factor/factor"
- "Full path to the factor executable to use when starting a listener."
- :type '(file :must-match t)
- :group 'factor)
-
-(defcustom factor-image "~/factor/factor.image"
- "Full path to the factor image to use when starting a listener."
- :type '(file :must-match t)
- :group 'factor)
-
-(defcustom factor-use-doc-window t
- "When on, use a separate window to display help information.
-Disable to see that information in the factor-listener comint
-window."
- :type 'boolean
- :group 'factor)
-
-(defcustom factor-listener-use-other-window t
- "Use a window other than the current buffer's when switching to
-the factor-listener buffer."
- :type 'boolean
- :group 'factor)
-
-(defcustom factor-listener-window-allow-split t
- "Allow window splitting when switching to the factor-listener
-buffer."
- :type 'boolean
- :group 'factor)
-
-(defcustom factor-help-always-ask t
- "When enabled, always ask for confirmation in help prompts."
- :type 'boolean
- :group 'factor)
-
-(defcustom factor-help-use-minibuffer t
- "When enabled, use the minibuffer for short help messages."
- :type 'boolean
- :group 'factor)
-
-(defcustom factor-display-compilation-output t
- "Display the REPL buffer before compiling files."
- :type 'boolean
- :group 'factor)
-
-(defcustom factor-mode-hook nil
- "Hook run when entering Factor mode."
- :type 'hook
- :group 'factor)
-
-(defcustom factor-help-mode-hook nil
- "Hook run by `factor-help-mode'."
- :type 'hook
- :group 'factor)
-
-(defgroup factor-faces nil
- "Faces used in Factor mode"
- :group 'factor
- :group 'faces)
-
-(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face)
- "Face for parsing words."
- :group 'factor-faces)
-
-(defface factor-font-lock-declaration (face-default-spec font-lock-keyword-face)
- "Face for declaration words (inline, parsing ...)."
- :group 'factor-faces)
-
-(defface factor-font-lock-comment (face-default-spec font-lock-comment-face)
- "Face for comments."
- :group 'factor-faces)
-
-(defface factor-font-lock-string (face-default-spec font-lock-string-face)
- "Face for strings."
- :group 'factor-faces)
-
-(defface factor-font-lock-stack-effect (face-default-spec font-lock-comment-face)
- "Face for stack effect specifications."
- :group 'factor-faces)
-
-(defface factor-font-lock-word-definition (face-default-spec font-lock-function-name-face)
- "Face for word, generic or method being defined."
- :group 'factor-faces)
-
-(defface factor-font-lock-symbol-definition (face-default-spec font-lock-variable-name-face)
- "Face for name of symbol being defined."
- :group 'factor-faces)
-
-(defface factor-font-lock-vocabulary-name (face-default-spec font-lock-constant-face)
- "Face for names of vocabularies in USE or USING."
- :group 'factor-faces)
-
-(defface factor-font-lock-type-definition (face-default-spec font-lock-type-face)
- "Face for type (tuple) names."
- :group 'factor-faces)
-
-(defface factor-font-lock-constructor (face-default-spec font-lock-type-face)
- "Face for constructors (<foo>)."
- :group 'factor-faces)
-
-(defface factor-font-lock-setter-word (face-default-spec font-lock-function-name-face)
- "Face for setter words (>>foo)."
- :group 'factor-faces)
-
-(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face)
- "Face for parsing words."
- :group 'factor-faces)
-
-(defface factor-font-lock-help-mode-headlines '((t (:bold t :weight bold)))
- "Face for headlines in help buffers."
- :group 'factor-faces)
-
-\f
-;;; Compatibility
-(when (not (fboundp 'ring-member))
- (defun ring-member (ring item)
- (catch 'found
- (dotimes (ind (ring-length ring) nil)
- (when (equal item (ring-ref ring ind))
- (throw 'found ind))))))
-
-\f
-;;; Factor mode font lock:
-
-(defconst factor--parsing-words
- '("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
- "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
- "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
- "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
- "IN:" "INSTANCE:" "INTERSECTION:"
- "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
- "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
- "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
- "TUPLE:" "T{" "t\\??" "TYPEDEF:"
- "UNION:" "USE:" "USING:" "V{" "VARS:" "W{"))
-
-(defconst factor--regex-parsing-words-ext
- (regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
- 'words))
-
-(defconst factor--declaration-words
- '("flushable" "foldable" "inline" "parsing" "recursive"))
-
-(defconst factor--regex-declaration-words
- (regexp-opt factor--declaration-words 'words))
-
-(defsubst factor--regex-second-word (prefixes)
- (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
-
-(defconst factor--regex-method-definition
- "^M: +\\([^ ]+\\) +\\([^ ]+\\)")
-
-(defconst factor--regex-word-definition
- (factor--regex-second-word '(":" "::" "GENERIC:")))
-
-(defconst factor--regex-type-definition
- (factor--regex-second-word '("TUPLE:" "SINGLETON:")))
-
-(defconst factor--regex-parent-type "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
-
-(defconst factor--regex-constructor "<[^ >]+>")
-
-(defconst factor--regex-setter "\\W>>[^ ]+\\b")
-
-(defconst factor--regex-symbol-definition
- (factor--regex-second-word '("SYMBOL:" "VAR:")))
-
-(defconst factor--regex-stack-effect " ( .* )")
-
-(defconst factor--regex-using-lines "^USING: +\\(\\([^;]\\|[\n\r\f]\\)*\\);")
-
-(defconst factor--regex-use-line "^USE: +\\(.*\\)$")
-
-(defconst factor--font-lock-keywords
- `((,factor--regex-stack-effect . 'factor-font-lock-stack-effect)
- ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
- ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
- '(2 'factor-font-lock-parsing-word)))
- factor--parsing-words)
- (,factor--regex-parsing-words-ext . 'factor-font-lock-parsing-word)
- (,factor--regex-declaration-words 1 'factor-font-lock-declaration)
- (,factor--regex-word-definition 2 'factor-font-lock-word-definition)
- (,factor--regex-type-definition 2 'factor-font-lock-type-definition)
- (,factor--regex-method-definition (1 'factor-font-lock-type-definition)
- (2 'factor-font-lock-word-definition))
- (,factor--regex-parent-type 1 'factor-font-lock-type-definition)
- (,factor--regex-constructor . 'factor-font-lock-constructor)
- (,factor--regex-setter . 'factor-font-lock-setter-word)
- (,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
- (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))
- "Font lock keywords definition for Factor mode.")
-
-\f
-;;; Factor mode syntax:
-
-(defconst factor--regex-definition-starters
- (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" "")))
-
-(defconst factor--regex-definition-start
- (format "^\\(%s:\\) " factor--regex-definition-starters))
-
-(defconst factor--regex-definition-end
- (format "\\(;\\( +%s\\)*\\)" factor--regex-declaration-words))
-
-(defconst factor--font-lock-syntactic-keywords
- `(("\\(#!\\)" (1 "<"))
- (" \\(!\\)" (1 "<"))
- ("^\\(!\\)" (1 "<"))
- ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))))
-
-(defvar factor-mode-syntax-table nil
- "Syntax table used while in Factor mode.")
-
-(if factor-mode-syntax-table
- ()
- (let ((i 0))
- (setq factor-mode-syntax-table (make-syntax-table))
-
- ;; Default is atom-constituent
- (while (< i 256)
- (modify-syntax-entry i "_ " factor-mode-syntax-table)
- (setq i (1+ i)))
-
- ;; Word components.
- (setq i ?0)
- (while (<= i ?9)
- (modify-syntax-entry i "w " factor-mode-syntax-table)
- (setq i (1+ i)))
- (setq i ?A)
- (while (<= i ?Z)
- (modify-syntax-entry i "w " factor-mode-syntax-table)
- (setq i (1+ i)))
- (setq i ?a)
- (while (<= i ?z)
- (modify-syntax-entry i "w " factor-mode-syntax-table)
- (setq i (1+ i)))
-
- ;; Whitespace
- (modify-syntax-entry ?\t " " factor-mode-syntax-table)
- (modify-syntax-entry ?\f " " factor-mode-syntax-table)
- (modify-syntax-entry ?\r " " factor-mode-syntax-table)
- (modify-syntax-entry ? " " factor-mode-syntax-table)
-
- ;; (end of) Comments
- (modify-syntax-entry ?\n ">" factor-mode-syntax-table)
-
- ;; Parenthesis
- (modify-syntax-entry ?\[ "(] " factor-mode-syntax-table)
- (modify-syntax-entry ?\] ")[ " factor-mode-syntax-table)
- (modify-syntax-entry ?{ "(} " factor-mode-syntax-table)
- (modify-syntax-entry ?} "){ " factor-mode-syntax-table)
-
- (modify-syntax-entry ?\( "()" factor-mode-syntax-table)
- (modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
-
- ;; Strings
- (modify-syntax-entry ?\" "\"" factor-mode-syntax-table)
- (modify-syntax-entry ?\\ "/" factor-mode-syntax-table)))
-
-\f
-;;; symbol-at-point
-
-(defun factor--beginning-of-symbol ()
- "Move point to the beginning of the current symbol."
- (while (eq (char-before) ?:) (backward-char))
- (skip-syntax-backward "w_"))
-
-(defun factor--end-of-symbol ()
- "Move point to the end of the current symbol."
- (skip-syntax-forward "w_")
- (while (looking-at ":") (forward-char)))
-
-(put 'factor-symbol 'end-op 'factor--end-of-symbol)
-(put 'factor-symbol 'beginning-op 'factor--beginning-of-symbol)
-
-(defsubst factor--symbol-at-point ()
- (let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
- (and (> (length s) 0) s)))
-
-\f
-;;; Factor mode indentation:
-
-(make-variable-buffer-local
- (defvar factor-indent-width factor-default-indent-width
- "Indentation width in factor buffers. A local variable."))
-
-(defun factor--guess-indent-width ()
- "Chooses an indentation value from existing code."
- (let ((word-cont "^ +[^ ]")
- (iw))
- (save-excursion
- (beginning-of-buffer)
- (while (not iw)
- (if (not (re-search-forward factor--regex-definition-start nil t))
- (setq iw factor-default-indent-width)
- (forward-line)
- (when (looking-at word-cont)
- (setq iw (current-indentation))))))
- iw))
-
-(defsubst factor--ppss-brackets-depth ()
- (nth 0 (syntax-ppss)))
-
-(defsubst factor--ppss-brackets-start ()
- (nth 1 (syntax-ppss)))
-
-(defun factor--ppss-brackets-end ()
- (save-excursion
- (goto-char (factor--ppss-brackets-start))
- (condition-case nil
- (progn (forward-sexp)
- (1- (point)))
- (error -1))))
-
-(defsubst factor--indentation-at (pos)
- (save-excursion (goto-char pos) (current-indentation)))
-
-(defsubst factor--at-first-char-p ()
- (= (- (point) (line-beginning-position)) (current-indentation)))
-
-(defconst factor--regex-single-liner
- (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
- "PRIVATE>" "<PRIVATE"
- "SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
-
-(defconst factor--regex-begin-of-def
- (format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
- factor--regex-definition-start
- factor--regex-single-liner))
-
-(defconst factor--regex-end-of-def-line
- (format "^.*%s" factor--regex-definition-end))
-
-(defconst factor--regex-end-of-def
- (format "\\(%s\\)\\|\\(%s .*\\)"
- factor--regex-end-of-def-line
- factor--regex-single-liner))
-
-(defsubst factor--at-begin-of-def ()
- (looking-at factor--regex-begin-of-def))
-
-(defsubst factor--at-end-of-def ()
- (looking-at factor--regex-end-of-def))
-
-(defsubst factor--looking-at-emptiness ()
- (looking-at "^[ \t]*$"))
-
-(defun factor--at-setter-line ()
- (save-excursion
- (beginning-of-line)
- (if (not (factor--looking-at-emptiness))
- (re-search-forward factor--regex-setter (line-end-position) t)
- (forward-line -1)
- (or (factor--at-constructor-line)
- (factor--at-setter-line)))))
-
-(defun factor--at-constructor-line ()
- (save-excursion
- (beginning-of-line)
- (re-search-forward factor--regex-constructor (line-end-position) t)))
-
-(defsubst factor--increased-indentation (&optional i)
- (+ (or i (current-indentation)) factor-indent-width))
-(defsubst factor--decreased-indentation (&optional i)
- (- (or i (current-indentation)) factor-indent-width))
-
-(defun factor--indent-in-brackets ()
- (save-excursion
- (beginning-of-line)
- (when (> (factor--ppss-brackets-depth) 0)
- (let ((op (factor--ppss-brackets-start))
- (cl (factor--ppss-brackets-end))
- (ln (line-number-at-pos)))
- (when (> ln (line-number-at-pos op))
- (if (and (> cl 0) (= ln (line-number-at-pos cl)))
- (factor--indentation-at op)
- (factor--increased-indentation (factor--indentation-at op))))))))
-
-(defun factor--indent-definition ()
- (save-excursion
- (beginning-of-line)
- (when (factor--at-begin-of-def) 0)))
-
-(defun factor--indent-setter-line ()
- (when (factor--at-setter-line)
- (save-excursion
- (let ((indent (and (factor--at-constructor-line) (current-indentation))))
- (while (not (or indent
- (bobp)
- (factor--at-begin-of-def)
- (factor--at-end-of-def)))
- (if (factor--at-constructor-line)
- (setq indent (factor--increased-indentation))
- (forward-line -1)))
- indent))))
-
-(defun factor--indent-continuation ()
- (save-excursion
- (forward-line -1)
- (while (and (not (bobp)) (factor--looking-at-emptiness))
- (forward-line -1))
- (if (or (factor--at-end-of-def) (factor--at-setter-line))
- (factor--decreased-indentation)
- (if (and (factor--at-begin-of-def)
- (not (looking-at factor--regex-using-lines)))
- (factor--increased-indentation)
- (current-indentation)))))
-
-(defun factor--calculate-indentation ()
- "Calculate Factor indentation for line at point."
- (or (and (bobp) 0)
- (factor--indent-definition)
- (factor--indent-in-brackets)
- (factor--indent-setter-line)
- (factor--indent-continuation)
- 0))
-
-(defun factor--indent-line ()
- "Indent current line as Factor code"
- (let ((target (factor--calculate-indentation))
- (pos (- (point-max) (point))))
- (if (= target (current-indentation))
- (if (< (current-column) (current-indentation))
- (back-to-indentation))
- (beginning-of-line)
- (delete-horizontal-space)
- (indent-to target)
- (if (> (- (point-max) pos) (point))
- (goto-char (- (point-max) pos))))))
-
-\f
-;; Factor mode:
-(defvar factor-mode-map (make-sparse-keymap)
- "Key map used by Factor mode.")
-
-(defsubst factor--beginning-of-defun (&optional times)
- (re-search-backward factor--regex-begin-of-def nil t times))
-
-(defsubst factor--end-of-defun ()
- (re-search-forward factor--regex-end-of-def nil t))
-
-;;;###autoload
-(defun factor-mode ()
- "A mode for editing programs written in the Factor programming language.
-\\{factor-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (use-local-map factor-mode-map)
- (setq major-mode 'factor-mode)
- (setq mode-name "Factor")
- ;; Font locking
- (set (make-local-variable 'comment-start) "! ")
- (set (make-local-variable 'parse-sexp-lookup-properties) t)
- (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
- (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
- (set (make-local-variable 'font-lock-defaults)
- `(factor--font-lock-keywords
- nil nil nil nil
- (font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
-
- (set-syntax-table factor-mode-syntax-table)
- ;; Defun navigation
- (set (make-local-variable 'beginning-of-defun-function) 'factor--beginning-of-defun)
- (set (make-local-variable 'end-of-defun-function) 'factor--end-of-defun)
- (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
- ;; Indentation
- (set (make-local-variable 'indent-line-function) 'factor--indent-line)
- (setq factor-indent-width (factor--guess-indent-width))
- (setq indent-tabs-mode nil)
- ;; ElDoc
- (set (make-local-variable 'eldoc-documentation-function) 'factor--eldoc)
-
- (run-hooks 'factor-mode-hook))
-
-(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
-
-\f
-;;; Factor listener mode:
-
-;;;###autoload
-(define-derived-mode factor-listener-mode comint-mode "Factor Listener"
- "Major mode for interacting with an inferior Factor listener process.
-\\{factor-listener-mode-map}"
- (set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
-
-(defvar factor--listener-buffer nil
- "The buffer in which the Factor listener is running.")
-
-(defun factor--listener-start-process ()
- "Start an inferior Factor listener process, using
-`factor-binary' and `factor-image'."
- (setq factor--listener-buffer
- (apply 'make-comint "factor" (expand-file-name factor-binary) nil
- `("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
- (with-current-buffer factor--listener-buffer
- (factor-listener-mode)))
-
-(defun factor--listener-process (&optional start)
- (or (and (buffer-live-p factor--listener-buffer)
- (get-buffer-process factor--listener-buffer))
- (if (not start)
- (error "No running factor listener. Try M-x run-factor.")
- (factor--listener-start-process)
- (factor--listener-process t))))
-
-;;;###autoload
-(defalias 'switch-to-factor 'run-factor)
-;;;###autoload
-(defun run-factor (&optional arg)
- "Show the factor-listener buffer, starting the process if needed."
- (interactive)
- (let ((buf (process-buffer (factor--listener-process t)))
- (pop-up-windows factor-listener-window-allow-split))
- (if factor-listener-use-other-window
- (pop-to-buffer buf)
- (switch-to-buffer buf))))
-
-(defun factor-telnet-to-port (port)
- (interactive "nPort: ")
- (switch-to-buffer
- (make-comint-in-buffer "factor-telnet" nil (cons "localhost" port))))
-
-(defun factor-telnet ()
- (interactive)
- (factor-telnet-to-port 9000))
-
-(defun factor-telnet-factory ()
- (interactive)
- (factor-telnet-to-port 9010))
-
-\f
-;;; Factor listener interaction:
-
-(defun factor--listener-send-cmd (cmd)
- (let ((proc (factor--listener-process)))
- (when proc
- (let* ((out (get-buffer-create "*factor messages*"))
- (beg (with-current-buffer out (goto-char (point-max)))))
- (comint-redirect-send-command-to-process cmd out proc nil t)
- (with-current-buffer factor--listener-buffer
- (while (not comint-redirect-completed) (sleep-for 0 1)))
- (with-current-buffer out
- (split-string (buffer-substring-no-properties beg (point-max))
- "[\"\f\n\r\v]+" t))))))
-
-;;;;; Current vocabulary:
-(make-variable-buffer-local
- (defvar factor--current-vocab nil
- "Current vocabulary."))
-
-(defconst factor--regexp-current-vocab "^IN: +\\([^ \r\n\f]+\\)")
-
-(defun factor--current-buffer-vocab ()
- (save-excursion
- (when (or (re-search-backward factor--regexp-current-vocab nil t)
- (re-search-forward factor--regexp-current-vocab nil t))
- (setq factor--current-vocab (match-string-no-properties 1)))))
-
-(defun factor--current-listener-vocab ()
- (car (factor--listener-send-cmd "USING: parser ; in get .")))
-
-(defun factor--set-current-listener-vocab (&optional vocab)
- (factor--listener-send-cmd
- (format "IN: %s" (or vocab (factor--current-buffer-vocab))))
- t)
-
-(defmacro factor--with-vocab (vocab &rest body)
- (let ((current (make-symbol "current")))
- `(let ((,current (factor--current-listener-vocab)))
- (factor--set-current-listener-vocab ,vocab)
- (prog1 (condition-case nil (progn . ,body) (error nil))
- (factor--set-current-listener-vocab ,current)))))
-
-(put 'factor--with-vocab 'lisp-indent-function 1)
-
-;;;;; Synchronous interaction:
-
-(defsubst factor--listener-vocab-cmds (cmds &optional vocab)
- (factor--with-vocab vocab
- (mapcar #'factor--listener-send-cmd cmds)))
-
-(defsubst factor--listener-vocab-cmd (cmd &optional vocab)
- (factor--with-vocab vocab
- (factor--listener-send-cmd cmd)))
-
-\f
-;;;;; Buffer cycling and docs
-
-
-(defconst factor--cycle-endings
- '(".factor" "-tests.factor" "-docs.factor"))
-
-(defconst factor--regex-cycle-endings
- (format "\\(.*?\\)\\(%s\\)$"
- (regexp-opt factor--cycle-endings)))
-
-(defconst factor--cycle-endings-ring
- (let ((ring (make-ring (length factor--cycle-endings))))
- (dolist (e factor--cycle-endings ring)
- (ring-insert ring e))))
-
-(defun factor--cycle-next (file)
- (let* ((match (string-match factor--regex-cycle-endings file))
- (base (and match (match-string-no-properties 1 file)))
- (ending (and match (match-string-no-properties 2 file)))
- (idx (and ending (ring-member factor--cycle-endings-ring ending)))
- (gfl (lambda (i) (concat base (ring-ref factor--cycle-endings-ring i)))))
- (if (not idx) file
- (let ((l (length factor--cycle-endings)) (i 1) next)
- (while (and (not next) (< i l))
- (when (file-exists-p (funcall gfl (+ idx i)))
- (setq next (+ idx i)))
- (setq i (1+ i)))
- (funcall gfl (or next idx))))))
-
-(defun factor-visit-other-file (&optional file)
- "Cycle between code, tests and docs factor files."
- (interactive)
- (find-file (factor--cycle-next (or file (buffer-file-name)))))
-
-\f
-;;;;; Interface: See
-
-(defconst factor--regex-error-marker "^Type :help for debugging")
-(defconst factor--regex-data-stack "^--- Data stack:")
-
-(defun factor--prune-ans-strings (ans)
- (nreverse
- (catch 'done
- (let ((res))
- (dolist (a ans res)
- (cond ((string-match factor--regex-stack-effect a)
- (throw 'done (cons a res)))
- ((string-match factor--regex-data-stack a)
- (throw 'done res))
- ((string-match factor--regex-error-marker a)
- (throw 'done nil))
- (t (push a res))))))))
-
-(defun factor--see-ans-to-string (ans)
- (let ((s (mapconcat #'identity (factor--prune-ans-strings ans) " "))
- (font-lock-verbose nil))
- (and (> (length s) 0)
- (with-temp-buffer
- (insert s)
- (factor-mode)
- (font-lock-fontify-buffer)
- (buffer-string)))))
-
-(defun factor--see-current-word (&optional word)
- (let ((word (or word (factor--symbol-at-point))))
- (when word
- (let ((answer (factor--listener-send-cmd (format "\\ %s see" word))))
- (and answer (factor--see-ans-to-string answer))))))
-
-(defalias 'factor--eldoc 'factor--see-current-word)
-
-(defun factor-see-current-word (&optional word)
- "Echo in the minibuffer information about word at point."
- (interactive)
- (let* ((proc (factor--listener-process))
- (word (or word (factor--symbol-at-point)))
- (msg (factor--see-current-word word)))
- (if msg (message "%s" msg)
- (if word (message "No help found for '%s'" word)
- (message "No word at point")))))
-
-;;; to fix:
-(defun factor-run-file ()
- (interactive)
- (when (and (buffer-modified-p)
- (y-or-n-p (format "Save file %s? " (buffer-file-name))))
- (save-buffer))
- (when factor-display-compilation-output
- (factor-display-output-buffer))
- (comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name)))
- (comint-send-string "*factor*" " run-file\n"))
-
-(defun factor-display-output-buffer ()
- (with-current-buffer "*factor*"
- (goto-char (point-max))
- (unless (get-buffer-window (current-buffer) t)
- (display-buffer (current-buffer) t))))
-
-(defun factor-send-string (str)
- (let ((n (length (split-string str "\n"))))
- (save-excursion
- (set-buffer "*factor*")
- (goto-char (point-max))
- (if (> n 1) (newline))
- (insert str)
- (comint-send-input))))
-
-(defun factor-send-region (start end)
- (interactive "r")
- (let ((str (buffer-substring start end))
- (n (count-lines start end)))
- (save-excursion
- (set-buffer "*factor*")
- (goto-char (point-max))
- (if (> n 1) (newline))
- (insert str)
- (comint-send-input))))
-
-(defun factor-send-definition ()
- (interactive)
- (factor-send-region (search-backward ":")
- (search-forward ";")))
-
-(defun factor-edit ()
- (interactive)
- (comint-send-string "*factor*" "\\ ")
- (comint-send-string "*factor*" (thing-at-point 'sexp))
- (comint-send-string "*factor*" " edit\n"))
-
-(defun factor-clear ()
- (interactive)
- (factor-send-string "clear"))
-
-(defun factor-comment-line ()
- (interactive)
- (beginning-of-line)
- (insert "! "))
-
-\f
-;;;; Factor help mode:
-
-(defvar factor-help-mode-map (make-sparse-keymap)
- "Keymap for Factor help mode.")
-
-(defconst factor--help-headlines
- (regexp-opt '("Definition"
- "Examples"
- "Generic word contract"
- "Inputs and outputs"
- "Parent topics:"
- "See also"
- "Syntax"
- "Vocabulary"
- "Warning"
- "Word description")
- t))
-
-(defconst factor--help-headlines-regexp (format "^%s" factor--help-headlines))
-
-(defconst factor--help-font-lock-keywords
- `((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines)
- ,@factor--font-lock-keywords))
-
-(defun factor-help-mode ()
- "Major mode for displaying Factor help messages.
-\\{factor-help-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (use-local-map factor-help-mode-map)
- (setq mode-name "Factor Help")
- (setq major-mode 'factor-help-mode)
- (set (make-local-variable 'font-lock-defaults)
- '(factor--help-font-lock-keywords t nil nil nil))
- (set (make-local-variable 'comint-redirect-subvert-readonly) t)
- (set (make-local-variable 'comint-redirect-echo-input) nil)
- (set (make-local-variable 'view-no-disable-on-exit) t)
- (view-mode)
- (setq view-exit-action
- (lambda (buffer)
- ;; Use `with-current-buffer' to make sure that `bury-buffer'
- ;; also removes BUFFER from the selected window.
- (with-current-buffer buffer
- (bury-buffer))))
- (run-mode-hooks 'factor-help-mode-hook))
-
-(defun factor--listener-help-buffer ()
- (with-current-buffer (get-buffer-create "*factor-help*")
- (let ((inhibit-read-only t)) (erase-buffer))
- (factor-help-mode)
- (current-buffer)))
-
-(defvar factor--help-history nil)
-
-(defun factor--listener-show-help (&optional see)
- (let* ((proc (factor--listener-process))
- (def (factor--symbol-at-point))
- (prompt (format "See%s help on%s: " (if see " short" "")
- (if def (format " (%s)" def) "")))
- (ask (or (not (eq major-mode 'factor-mode))
- (not def)
- factor-help-always-ask))
- (cmd (format "\\ %s %s"
- (if ask (read-string prompt nil 'factor--help-history def) def)
- (if see "see" "help")))
- (hb (factor--listener-help-buffer)))
- (comint-redirect-send-command-to-process cmd hb proc nil)
- (pop-to-buffer hb)
- (beginning-of-buffer hb)))
-
-;;;; Interface: see/help commands
-
-(defun factor-see (&optional arg)
- "See a help summary of symbol at point.
-By default, the information is shown in the minibuffer. When
-called with a prefix argument, the information is displayed in a
-separate help buffer."
- (interactive "P")
- (if (if factor-help-use-minibuffer (not arg) arg)
- (factor-see-current-word)
- (factor--listener-show-help t)))
-
-(defun factor-help ()
- "Show extended help about the symbol at point, using a help
-buffer."
- (interactive)
- (factor--listener-show-help))
-
-\f
-
-(defun factor-refresh-all ()
- "Reload source files and documentation for all loaded
-vocabularies which have been modified on disk."
- (interactive)
- (comint-send-string "*factor*" "refresh-all\n"))
-
-\f
-;;; Key bindings:
-
-(defun factor--define-key (key cmd &optional both)
- (let ((ms (list factor-mode-map)))
- (when both (push factor-help-mode-map ms))
- (dolist (m ms)
- (define-key m (vector '(control ?c) key) cmd)
- (define-key m (vector '(control ?c) `(control ,key)) cmd))))
-
-(defun factor--define-auto-indent-key (key)
- (define-key factor-mode-map (vector key)
- (lambda (n)
- (interactive "p")
- (self-insert-command n)
- (indent-for-tab-command))))
-
-(factor--define-key ?f 'factor-run-file)
-(factor--define-key ?r 'factor-send-region)
-(factor--define-key ?d 'factor-send-definition)
-(factor--define-key ?s 'factor-see t)
-(factor--define-key ?e 'factor-edit)
-(factor--define-key ?z 'switch-to-factor t)
-(factor--define-key ?o 'factor-visit-other-file)
-(factor--define-key ?c 'comment-region)
-
-(factor--define-auto-indent-key ?\])
-(factor--define-auto-indent-key ?\})
-
-(define-key factor-mode-map "\C-ch" 'factor-help)
-(define-key factor-help-mode-map "\C-ch" 'factor-help)
-(define-key factor-mode-map "\C-m" 'newline-and-indent)
-
-(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
-
-
-\f
-(provide 'factor)
-;;; factor.el ends here
| C-cC-ev | edit vocabulary (fuel-edit-vocabulary) |
| C-cC-ew | edit word (fuel-edit-word-at-point) |
| C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) |
+ | C-cC-el | load vocabs in USING: form |
|-----------------+------------------------------------------------------------|
| C-cC-er | eval region |
| C-M-r, C-cC-ee | eval region, extending it to definition boundaries |
| C-cC-xi | replace word by its definition (fuel-refactor-inline-word) |
| C-cC-xw | rename all uses of a word (fuel-refactor-rename-word) |
| C-cC-xa | extract region as a separate ARTICLE: form |
+ | C-cC-xg | convert current word definition into GENERIC + method |
+ | | (fuel-refactor-make-generic) |
|-----------------+------------------------------------------------------------|
*** In the listener:
(when (string-match factor-mode--cycle-basename-regex basename)
(cons (match-string 1 basename) (match-string 2 basename))))
-(defun factor-mode--cycle-next (file)
+(defun factor-mode--cycle-next (file skip)
(let* ((dir (file-name-directory file))
(basename (file-name-nondirectory file))
(p/s (factor-mode--cycle-split basename))
(let* ((suffix (ring-ref ring (+ i idx)))
(path (expand-file-name (concat prefix suffix) dir)))
(when (or (file-exists-p path)
- (and (not (member suffix factor-mode--cycling-no-ask))
+ (and (not skip)
+ (not (member suffix factor-mode--cycling-no-ask))
(y-or-n-p (format "Create %s? " path))))
(setq result path))
(when (and (not factor-mode-cycle-always-ask-p)
(defsubst factor-mode--cycling-setup ()
(setq factor-mode--cycling-no-ask nil))
-(defun factor-mode-visit-other-file (&optional file)
- "Cycle between code, tests and docs factor files."
- (interactive)
- (let ((file (factor-mode--cycle-next (or file (buffer-file-name)))))
+(defun factor-mode-visit-other-file (&optional skip)
+ "Cycle between code, tests and docs factor files.
+With prefix, non-existing files will be skipped."
+ (interactive "P")
+ (let ((file (factor-mode--cycle-next (buffer-file-name) skip)))
(unless file (error "No other file found"))
(find-file file)
(unless (file-exists-p file)
:type 'boolean)
+(defcustom fuel-autodoc-eval-using-form-p nil
+ "When enabled, automatically load vocabularies in USING: form
+to display autodoc messages.
+
+In order to show autodoc messages for words in a Factor buffer,
+the used vocabularies must be loaded in the Factor image. Setting
+this variable to `t' will do that automatically for you,
+asynchronously. That means that you'll be able to move around
+while the vocabs are being loaded, but no other FUEL
+functionality will be available until loading finishes (and it
+may take a while). Thus, this functionality is disabled by
+default. You can force loading the vocabs in a Factor buffer
+USING: form with \\[fuel-load-usings]."
+ :group 'fuel-autodoc
+ :type 'boolean)
+
\f
;;; Eldoc function:
(let ((word (or word (fuel-syntax-symbol-at-point)))
(fuel-log--inhibit-p t))
(when word
- (let* ((cmd (if (fuel-syntax--in-using)
+ (let* ((usings (if fuel-autodoc-eval-using-form-p :usings t))
+ (cmd (if (fuel-syntax--in-using)
`(:fuel* (,word fuel-vocab-summary) :in t)
- `(:fuel* (((:quote ,word) synopsis :get)) :in)))
+ `(:fuel* ((,word :usings fuel-word-synopsis)) t ,usings)))
(ret (fuel-eval--send/wait cmd fuel-autodoc--timeout))
(res (fuel-eval--retort-result ret)))
(when (and ret (not (fuel-eval--retort-error ret)) (stringp res))
(t (error "Invalid 'in' (%s)" in))))
(defsubst factor--fuel-usings (usings)
- (cond ((null usings) :usings)
+ (cond ((or (null usings) (eq usings :usings)) :usings)
((eq usings t) nil)
((listp usings) `(:array ,@usings))
(t (error "Invalid 'usings' (%s)" usings))))
($nl . fuel-markup--newline)
($notes . fuel-markup--notes)
($operation . fuel-markup--link)
+ ($or . fuel-markup--or)
($parsing-note . fuel-markup--parsing-note)
($predicate . fuel-markup--predicate)
($prettyprinting-note . fuel-markup--prettyprinting-note)
(fuel-markup--instance (cons '$instance (cdr e)))
(insert " or f "))
+(defun fuel-markup--or (e)
+ (let ((fst (car (cdr e)))
+ (mid (butlast (cddr e)))
+ (lst (car (last (cdr e)))))
+ (insert (format "%s" fst))
+ (dolist (m mid) (insert (format ", %s" m)))
+ (insert (format " or %s" lst))))
+
(defun fuel-markup--values (e)
(fuel-markup--insert-heading "Inputs and outputs")
(dolist (val (cdr e))
(let ((file (car (fuel-mode--read-file arg))))
(when file (fuel-debug--uses-for-file file))))
+(defun fuel-load-usings ()
+ "Loads all vocabularies in the current buffer's USING: from.
+Useful to activate autodoc help messages in a vocabulary not yet
+loaded. See documentation for `fuel-autodoc-eval-using-form-p'
+for details."
+ (interactive)
+ (message "Loading all vocabularies in USING: form ...")
+ (let ((err (fuel-eval--retort-error
+ (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000))))
+ (message (if err "Warning: some vocabularies failed to load"
+ "All vocabularies loaded"))))
+
\f
;;; Minor mode definition:
(fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point)
(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
-(fuel-mode--key ?e ?l 'fuel-run-file)
+(fuel-mode--key ?e ?k 'fuel-run-file)
+(fuel-mode--key ?e ?l 'fuel-load-usings)
(fuel-mode--key ?e ?r 'fuel-eval-region)
(fuel-mode--key ?e ?u 'fuel-update-usings)
(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
(fuel-mode--key ?x ?a 'fuel-refactor-extract-article)
(fuel-mode--key ?x ?i 'fuel-refactor-inline-word)
+(fuel-mode--key ?x ?g 'fuel-refactor-make-generic)
(fuel-mode--key ?x ?r 'fuel-refactor-extract-region)
(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp)
(fuel-mode--key ?x ?v 'fuel-refactor-extract-vocab)
(if (looking-at-p ";") (point)
(fuel-syntax--end-of-symbol-pos))))
+\f
+;;; Convert word to generic + method:
+
+(defun fuel-refactor-make-generic ()
+ "Inserts a new generic definition with the current word's stack effect.
+The word's body is put in a new method for the generic."
+ (interactive)
+ (let ((p (point)))
+ (fuel-syntax--beginning-of-defun)
+ (unless (re-search-forward fuel-syntax--word-signature-regex nil t)
+ (goto-char p)
+ (error "Cannot find a proper word definition here"))
+ (let ((begin (match-beginning 0))
+ (end (match-end 0))
+ (name (match-string-no-properties 1))
+ (cls (read-string "Method's class (object): " nil nil "object")))
+ (goto-char begin)
+ (insert "GENERIC")
+ (goto-char (+ end 7))
+ (newline 2)
+ (insert "M: " cls " " name " "))))
+
\f
;;; Inline word:
fuel-syntax--end-of-def-line-regex
fuel-syntax--single-liner-regex))
+(defconst fuel-syntax--word-signature-regex
+ (format ":[^ ]* \\([^ ]+\\)\\(%s\\)*" fuel-syntax--stack-effect-regex))
+
(defconst fuel-syntax--defun-signature-regex
- (format "\\(%s\\|%s\\)"
- (format ":[^ ]* [^ ]+\\(%s\\)*" fuel-syntax--stack-effect-regex)
- "M[^:]*: [^ ]+ [^ ]+"))
+ (format "\\(%s\\|%s\\)" fuel-syntax--word-signature-regex "M[^:]*: [^ ]+ [^ ]+"))
(defconst fuel-syntax--constructor-decl-regex
"\\_<C: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
+++ /dev/null
-! 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
-
-: <packet> ( link id kind -- packet )
- packet new
- swap >>kind
- swap >>id
- swap >>link
- 0 >>a1
- BUFSIZE 0 <array> >>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 ;
-
-: <device-task> ( 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 ;
-
-: <handler-task> ( 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 } ;
-
-: <idle-task> ( 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 } ;
-
-: <work-task> ( 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 <array> to: task-tab
- f to: tracing
- 0 to: hold-count
- 0 to: qpkt-count ;
-
-: start ( -- )
- I_IDLE 1 10000 <idle-task> drop
-
- I_WORK 1000
- f 0 K_WORK <packet> 0 K_WORK <packet>
- <work-task> drop
-
- I_HANDLERA 2000
- f I_DEVA K_DEV <packet>
- I_DEVA K_DEV <packet>
- I_DEVA K_DEV <packet>
- <handler-task> drop
-
- I_HANDLERB 3000
- f I_DEVB K_DEV <packet>
- I_DEVB K_DEV <packet>
- I_DEVB K_DEV <packet>
- <handler-task> drop
-
- I_DEVA 4000 f <device-task> drop
- I_DEVB 4000 f <device-task> drop ;
-
-: check ( -- )
- qpkt-count 23246 assert=
- hold-count 9297 assert= ;
-
-: run ( -- )
- init
- start
- schedule check ;
+++ /dev/null
-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 }
- } ;
+++ /dev/null
-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 ;
bignum_unsigned_logbitp(int shift, bignum_type bignum)
{
bignum_length_type len = (BIGNUM_LENGTH (bignum));
- bignum_digit_type digit;
int index = shift / BIGNUM_DIGIT_LENGTH;
- int p;
if (index >= len)
return 0;
- digit = (BIGNUM_REF (bignum, index));
- p = shift % BIGNUM_DIGIT_LENGTH;
- return digit & (1 << p);
+ bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ int p = shift % BIGNUM_DIGIT_LENGTH;
+ bignum_digit_type mask = ((F_FIXNUM)1) << p;
+ return (digit & mask) ? 1 : 0;
}
/* Allocates memory */
projects / factor.git / commitdiff