-! 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>
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
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 )
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
dup 0 -> setCanChooseDirectories:
dup 0 -> setAllowsMultipleSelection: ;
-: NSOKButton 1 ;
-: NSCancelButton 0 ;
+CONSTANT: NSOKButton 1
+CONSTANT: NSCancelButton 0
: open-panel ( -- paths )
<NSOpenPanel>
! 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 ) ;
swap prefix [ encode-type "0" append ] 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 )
[
CONSTANT: NSOpenGLPFAPixelBuffer 90
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
-
-CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
-
-
CONSTANT: NSOpenGLCPSwapInterval 222
<PRIVATE
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"
{ $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
\ 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
! 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
] contains-node?
] unit-test
-: blah f ;
+: blah ( -- value ) f ;
DEFER: a
bool shouldSmoothFonts
) ;
-FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
-
FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
+CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
+
+FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
+
<PRIVATE
: bitmap-flags ( -- flags )
tools.test db.tester continuations ;
IN: db.errors.postgresql.tests
-postgresql-test-db [
+[
[ "drop table foo;" sql-command ] ignore-errors
[ "drop table ship;" sql-command ] ignore-errors
sql-syntax-error?
] must-fail-with
-] with-db
+] test-postgresql
USING: definitions io.launcher kernel parser words sequences math
math.parser namespaces editors make system combinators.short-circuit
-fry threads ;
+fry threads vocabs.loader ;
IN: editors.emacs
SYMBOL: emacsclient-path
where first2 emacsclient ;
[ emacsclient ] edit-hook set-global
+
+os windows? [ "editors.emacs.windows" require ] when
= (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' )
{
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 )
: 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 = ;
'[ handle>> _ wait-for-fd ] with-timeout ;
! Some general stuff
-: file-mode OCT: 0666 ;
+CONSTANT: file-mode OCT: 0666
! Readers
: (refill) ( port -- n )
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 ;
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>
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 ;
[ [ \ 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 ;
! 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
! 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 )
: 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 inference-error ] ?if ;
: check-effect ( word effect -- )
- over stack-effect {
- { [ dup not ] [ 2drop ?missing-effect ] }
- { [ 2dup effect<= ] [ 3drop ] }
- [ effect-error ]
- } cond ;
+ over required-stack-effect 2dup effect<=
+ [ 3drop ] [ effect-error ] if ;
: finish-word ( word -- )
- current-effect
- [ check-effect ]
- [ drop recorded get push ]
- [ "inferred-effect" set-word-prop ]
- 2tri ;
+ [ current-effect check-effect ]
+ [ recorded get push ]
+ [ t "inferred-effect" set-word-prop ]
+ tri ;
: cannot-infer-effect ( word -- * )
"cannot-infer" word-prop throw ;
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 )
[
\ 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
[ ] 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
IN: tools.profiler.tests
USING: accessors tools.profiler tools.test kernel memory math
-threads alien tools.profiler.private sequences compiler.units
+threads alien tools.profiler.private sequences compiler
words ;
[ t ] [
[ 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? ;
! 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 ;
3bi ;
: key-up-event>gesture ( event -- gesture )
- dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
+ [ event-modifiers ] [ 0 XLookupKeysym key-code ] bi <key-up> ;
M: world key-up-event
[ key-up-event>gesture ] dip propagate-key-gesture ;
: (fill- ( frame grid-layout quot1 quot2 -- pref-dim gap filled-cell dims )
[ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline
-: available-space ( pref-dim gap dims -- avail )
- length 1+ * [-] ; inline
-
: -center) ( pref-dim gap filled-cell dims -- )
[ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline
CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
-CONSTANT: focus-border-color COLOR: dark-gray
\ No newline at end of file
+CONSTANT: focus-border-color COLOR: dark-gray
--- /dev/null
+! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays ui ui.gadgets
+ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
+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
+math.vectors classes.tuple opengl.gl threads math.geometry.rect
+environment ascii ;
+IN: ui.x11
+
+SINGLETON: x11-ui-backend
+
+: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
+
+TUPLE: x11-handle-base glx ;
+TUPLE: x11-handle < x11-handle-base xic window ;
+TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
+
+C: <x11-handle> x11-handle
+C: <x11-pixmap-handle> x11-pixmap-handle
+
+M: world expose-event nip relayout ;
+
+M: world configure-event
+ over configured-loc >>window-loc
+ swap configured-dim >>dim
+ ! In case dimensions didn't change
+ relayout-1 ;
+
+CONSTANT: modifiers
+ {
+ { S+ HEX: 1 }
+ { C+ HEX: 4 }
+ { A+ HEX: 8 }
+ }
+
+CONSTANT: key-codes
+ H{
+ { HEX: FF08 "BACKSPACE" }
+ { HEX: FF09 "TAB" }
+ { HEX: FF0D "RET" }
+ { HEX: FF8D "ENTER" }
+ { HEX: FF1B "ESC" }
+ { HEX: FFFF "DELETE" }
+ { HEX: FF50 "HOME" }
+ { HEX: FF51 "LEFT" }
+ { HEX: FF52 "UP" }
+ { HEX: FF53 "RIGHT" }
+ { HEX: FF54 "DOWN" }
+ { HEX: FF55 "PAGE_UP" }
+ { HEX: FF56 "PAGE_DOWN" }
+ { HEX: FF57 "END" }
+ { HEX: FF58 "BEGIN" }
+ { HEX: FFBE "F1" }
+ { HEX: FFBF "F2" }
+ { HEX: FFC0 "F3" }
+ { HEX: FFC1 "F4" }
+ { HEX: FFC2 "F5" }
+ { HEX: FFC3 "F6" }
+ { HEX: FFC4 "F7" }
+ { HEX: FFC5 "F8" }
+ { HEX: FFC6 "F9" }
+ }
+
+: key-code ( keysym -- keycode action? )
+ dup key-codes at [ t ] [ 1string f ] ?if ;
+
+: event-modifiers ( event -- seq )
+ XKeyEvent-state modifiers modifier ;
+
+: valid-input? ( string gesture -- ? )
+ over empty? [ 2drop f ] [
+ mods>> { f { S+ } } member? [
+ [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
+ ] [
+ [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
+ ] if
+ ] if ;
+
+: key-down-event>gesture ( event world -- string gesture )
+ dupd
+ handle>> xic>> lookup-string
+ [ swap event-modifiers ] dip key-code <key-down> ;
+
+M: world key-down-event
+ [ key-down-event>gesture ] keep
+ [ propagate-key-gesture drop ]
+ [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
+ 3bi ;
+
+: key-up-event>gesture ( event -- gesture )
+ dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
+
+M: world key-up-event
+ [ key-up-event>gesture ] dip propagate-key-gesture ;
+
+: mouse-event>gesture ( event -- modifiers button loc )
+ [ event-modifiers ]
+ [ XButtonEvent-button ]
+ [ mouse-event-loc ]
+ tri ;
+
+M: world button-down-event
+ [ mouse-event>gesture [ <button-down> ] dip ] dip
+ send-button-down ;
+
+M: world button-up-event
+ [ mouse-event>gesture [ <button-up> ] dip ] dip
+ send-button-up ;
+
+: mouse-event>scroll-direction ( event -- pair )
+ XButtonEvent-button {
+ { 4 { 0 -1 } }
+ { 5 { 0 1 } }
+ { 6 { -1 0 } }
+ { 7 { 1 0 } }
+ } at ;
+
+M: world wheel-event
+ [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
+ send-wheel ;
+
+M: world enter-event motion-event ;
+
+M: world leave-event 2drop forget-rollover ;
+
+M: world motion-event
+ [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
+ move-hand fire-motion ;
+
+M: world focus-in-event
+ nip
+ dup handle>> xic>> XSetICFocus focus-world ;
+
+M: world focus-out-event
+ nip
+ dup handle>> xic>> XUnsetICFocus unfocus-world ;
+
+M: world selection-notify-event
+ [ handle>> window>> selection-from-event ] keep
+ user-input ;
+
+: supported-type? ( atom -- ? )
+ { "UTF8_STRING" "STRING" "TEXT" }
+ [ x-atom = ] with any? ;
+
+: clipboard-for-atom ( atom -- clipboard )
+ {
+ { XA_PRIMARY [ selection get ] }
+ { XA_CLIPBOARD [ clipboard get ] }
+ [ drop <clipboard> ]
+ } case ;
+
+: encode-clipboard ( string type -- bytes )
+ XSelectionRequestEvent-target
+ XA_UTF8_STRING = utf8 ascii ? encode ;
+
+: set-selection-prop ( evt -- )
+ dpy get swap
+ [ XSelectionRequestEvent-requestor ] keep
+ [ XSelectionRequestEvent-property ] keep
+ [ XSelectionRequestEvent-target ] keep
+ [ 8 PropModeReplace ] dip
+ [
+ XSelectionRequestEvent-selection
+ clipboard-for-atom contents>>
+ ] keep encode-clipboard dup length XChangeProperty drop ;
+
+M: world selection-request-event
+ drop dup XSelectionRequestEvent-target {
+ { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
+ { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
+ { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
+ [ drop send-notify-failure ]
+ } cond ;
+
+M: x11-ui-backend (close-window) ( handle -- )
+ dup xic>> XDestroyIC
+ dup glx>> destroy-glx
+ window>> dup unregister-window
+ destroy-window ;
+
+M: world client-event
+ swap close-box? [ ungraft ] [ drop ] if ;
+
+: gadget-window ( world -- )
+ dup window-loc>> over rect-dim glx-window
+ over "Factor" create-xic rot <x11-handle>
+ 2dup window>> register-window
+ >>handle drop ;
+
+: wait-event ( -- event )
+ QueuedAfterFlush events-queued 0 > [
+ next-event dup
+ None XFilterEvent zero? [ drop wait-event ] unless
+ ] [
+ ui-wait wait-event
+ ] if ;
+
+M: x11-ui-backend do-events
+ wait-event dup XAnyEvent-window window dup
+ [ handle-event ] [ 2drop ] if ;
+
+: x-clipboard@ ( gadget clipboard -- prop win )
+ atom>> swap
+ find-world handle>> window>> ;
+
+M: x-clipboard copy-clipboard
+ [ x-clipboard@ own-selection ] keep
+ (>>contents) ;
+
+M: x-clipboard paste-clipboard
+ [ find-world handle>> window>> ] dip atom>> convert-selection ;
+
+: init-clipboard ( -- )
+ XA_PRIMARY <x-clipboard> selection set-global
+ XA_CLIPBOARD <x-clipboard> clipboard set-global ;
+
+: set-title-old ( dpy window string -- )
+ dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
+
+: set-title-new ( dpy window string -- )
+ [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
+ utf8 encode dup length XChangeProperty drop ;
+
+M: x11-ui-backend set-title ( string world -- )
+ handle>> window>> swap
+ [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
+
+M: x11-ui-backend set-fullscreen* ( ? world -- )
+ handle>> window>> "XClientMessageEvent" <c-object>
+ tuck set-XClientMessageEvent-window
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
+ over set-XClientMessageEvent-data0
+ ClientMessage over set-XClientMessageEvent-type
+ dpy get over set-XClientMessageEvent-display
+ "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
+ 32 over set-XClientMessageEvent-format
+ "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
+ [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
+
+M: x11-ui-backend (open-window) ( world -- )
+ dup gadget-window
+ handle>> window>> dup set-closable map-window ;
+
+M: x11-ui-backend raise-window* ( world -- )
+ handle>> [
+ dpy get swap window>> XRaiseWindow drop
+ ] when* ;
+
+M: x11-handle select-gl-context ( handle -- )
+ dpy get swap
+ [ window>> ] [ glx>> ] bi glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-handle flush-gl-context ( handle -- )
+ dpy get swap window>> glXSwapBuffers ;
+
+M: x11-pixmap-handle select-gl-context ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-pixmap-handle flush-gl-context ( handle -- )
+ drop ;
+
+M: x11-ui-backend (open-offscreen-buffer) ( world -- )
+ dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
+M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> glXDestroyGLXPixmap ]
+ [ pixmap>> XFreePixmap drop ]
+ [ glx>> glXDestroyContext ] 2tri ;
+
+M: x11-ui-backend offscreen-pixels ( world -- alien w h )
+ [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
+
+M: x11-ui-backend ui ( -- )
+ [
+ f [
+ [
+ init-clipboard
+ start-ui
+ event-loop
+ ] with-xim
+ ] with-x
+ ] ui-running ;
+
+M: x11-ui-backend beep ( -- )
+ dpy get 100 XBell drop ;
+
+x11-ui-backend ui-backend set-global
+
+[ "DISPLAY" os-env "ui" "listener" ? ]
+main-vocab-hook set-global
[ 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
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
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
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
[ [ 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
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"
- [ word-prop ] bi-curry@ bi or ;
+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"
{ $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 } "."
} ;
: 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 )
! 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
CONSTANT: initial-seed 42
CONSTANT: line-length 60
-USE: math.private
-
: random ( seed -- n seed )
>float IA * IC + IM mod [ IM /f ] keep ; 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
IN: benchmark.raytracer
! parameters
-: light
- #! Normalized { -1 -3 2 }.
+
+! Normalized { -1 -3 2 }.
+CONSTANT: light
double-array{
-0.2672612419124244
-0.8017837257372732
0.5345224838248488
- } ; inline
+ }
CONSTANT: oversampling 4
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
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 ;
: 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 ;
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 ;
! 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 ;
: ?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
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 ;
math.order math.rectangles ;
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 ;
TUPLE: nehe3-gadget < gadget ;
-: width 256 ;
-: height 256 ;
+CONSTANT: width 256
+CONSTANT: height 256
: <nehe3-gadget> ( -- gadget )
nehe3-gadget new ;
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
: $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 ;
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) ;
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
-! 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 ;
projects / factor.git / commitdiff