From ef7b5b92f14a85b94b0064a65b6ae772583eff92 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 19 Jan 2010 19:12:00 -0800 Subject: [PATCH 01/72] add note to game.worlds docs that draw-world* and resize-world can have methods added in addition to the *-game-world specific methods --- extra/game/worlds/worlds-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/game/worlds/worlds-docs.factor b/extra/game/worlds/worlds-docs.factor index 75aed4dbda..c94126bfb0 100644 --- a/extra/game/worlds/worlds-docs.factor +++ b/extra/game/worlds/worlds-docs.factor @@ -16,7 +16,7 @@ HELP: game-attributes } ; HELP: game-world -{ $class-description "A subclass of " { $link world } " that automatically sets up and manages connections to the " { $vocab-link "game.loop" } ", " { $vocab-link "game.input" } ", and " { $vocab-link "audio.engine" } " libraries. It does this by providing methods on " { $link begin-world } ", " { $link end-world } ", and " { $link draw* } ". Subclasses can provide their own world setup and teardown code by adding methods to the " { $link begin-game-world } " and " { $link end-game-world } " generic words." +{ $class-description "A subclass of " { $link world } " that automatically sets up and manages connections to the " { $vocab-link "game.loop" } ", " { $vocab-link "game.input" } ", and " { $vocab-link "audio.engine" } " libraries. It does this by providing methods on " { $link begin-world } ", " { $link end-world } ", and " { $link draw* } ". Subclasses can provide their own world setup, teardown, and update code by adding methods to the " { $link begin-game-world } " and " { $link end-game-world } " generic words. The standard " { $snippet "world" } " generics " { $link draw-world* } " and " { $link resize-world } " can also be given methods to draw the window contents and handle resize events. The " { $snippet "draw-world*" } " method will be invoked in a tight loop by the game loop." $nl "The game-world tuple has the following publicly accessible slots:" { $list @@ -49,6 +49,7 @@ ARTICLE: "game.worlds" "Game worlds" begin-game-world end-game-world tick-game-world -} ; +} +"Additionally, the standard " { $snippet "world" } " generics " { $link draw-world* } " and " { $link resize-world } " can also be given methods to draw the window contents and handle resize events. The " { $snippet "draw-world*" } " method will be invoked in a tight loop by the game loop." ; ABOUT: "game.worlds" From 5279845ee0d5944d2d65975c2c873f673c7092b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 Jan 2010 07:01:29 -0600 Subject: [PATCH 02/72] tools.deploy.shaker: also include tools.errors if user requests debugger to be part of image. This ensures useful printouts of parse errors --- basis/tools/deploy/shaker/shaker.factor | 1 + 1 file changed, 1 insertion(+) mode change 100644 => 100755 basis/tools/deploy/shaker/shaker.factor diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor old mode 100644 new mode 100755 index 06009992ad..71191d0fe6 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -545,6 +545,7 @@ SYMBOL: deploy-vocab [ strip-debugger? [ "debugger" require + "tools.errors" require "inspector" require deploy-ui? get [ "ui.debugger" require From e68996c511840304bfc2a9c9bddd330df56b49d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 Jan 2010 07:02:48 -0600 Subject: [PATCH 03/72] game.input.dinput: fix load error --- basis/game/input/dinput/dinput.factor | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) mode change 100644 => 100755 basis/game/input/dinput/dinput.factor diff --git a/basis/game/input/dinput/dinput.factor b/basis/game/input/dinput/dinput.factor old mode 100644 new mode 100755 index 964b952cb8..d3540a99a9 --- a/basis/game/input/dinput/dinput.factor +++ b/basis/game/input/dinput/dinput.factor @@ -1,13 +1,12 @@ -USING: accessors alien alien.c-types alien.strings arrays -assocs byte-arrays combinators combinators.short-circuit -continuations game.input game.input.dinput.keys-array -io.encodings.utf16 io.encodings.utf16n kernel locals math -math.bitwise math.rectangles namespaces parser sequences -shuffle specialized-arrays ui.backend.windows vectors -windows.com windows.directx.dinput -windows.directx.dinput.constants .errors windows.kernel32 -windows.messages .ole32 windows.user32 classes.struct -alien.data ; +USING: accessors alien alien.c-types alien.strings arrays assocs +byte-arrays combinators combinators.short-circuit continuations +game.input game.input.dinput.keys-array io.encodings.utf16 +io.encodings.utf16n kernel locals math math.bitwise +math.rectangles namespaces parser sequences shuffle +specialized-arrays ui.backend.windows vectors windows.com +windows.directx.dinput windows.directx.dinput.constants +windows.kernel32 windows.messages windows.ole32 windows.errors +windows.user32 classes.struct alien.data ; SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA IN: game.input.dinput From ed16e89999d116d230554ebe72697175fa72e4e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Philipp=20Br=C3=BCschweiler?= Date: Wed, 20 Jan 2010 16:57:24 +0100 Subject: [PATCH 04/72] misc: update factor.vim and it's template --- misc/factor.vim.fgen | 108 +++++++++++++++++++------------------ misc/vim/syntax/factor.vim | 15 +++--- 2 files changed, 63 insertions(+), 60 deletions(-) diff --git a/misc/factor.vim.fgen b/misc/factor.vim.fgen index 4da54e055c..42f150ac34 100644 --- a/misc/factor.vim.fgen +++ b/misc/factor.vim.fgen @@ -33,11 +33,11 @@ else set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255 endif -syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple +syn cluster factorCluster contains=factorComment,factorFryDirective,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorBackslash,factorLiteral,factorLiteralBlock,@factorWordOps,factorAlien,factorTuple,factorStruct syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained -syn match factorComment /\<#! .*/ contains=factorTodo -syn match factorComment /\.*/ contains=factorTodo +syn match factorComment /\.*/ contains=factorTodo syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorLiteralStackEffect,factorArray0,factorQuotation0 @@ -54,7 +54,8 @@ syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\/ end=/\\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN -syn keyword factorBoolean boolean f general-t t +syn keyword factorBoolean f t +syn match factorFryDirective /\<\(@\|_\)\>/ contained syn keyword factorCompileDirective inline foldable recursive <% @@ -75,34 +76,41 @@ syn keyword factorCompileDirective inline foldable recursive syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal syn cluster factorNumber contains=@factorReal,factorComplex syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr -syn match factorInt /\<-\=\d\+\>/ -syn match factorFloat /\<-\=\d*\.\d\+\>/ -syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/ +syn match factorInt /\<-\=[0-9]\([0-9,]*[0-9]\)\?\>/ +syn match factorFloat /\<-\=[0-9]\([0-9,]*[0-9]\)\?\.[0-9,]*[0-9]\+\>/ +syn match factorRatio /\<-\=[0-9]\([0-9,]*[0-9]\)\?\(+[0-9]\([0-9,]*[0-9]\+\)\?\)\?\/-\=[0-9]\([0-9,]*[0-9]\+\)\?\.\?\>/ syn region factorComplex start=/\/ end=/\<}\>/ contains=@factorReal -syn match factorBinErr /\/ -syn match factorBinary /\/ -syn match factorHexErr /\/ -syn match factorHex /\/ -syn match factorOctErr /\/ -syn match factorOctal /\/ +syn match factorBinErr /\/ +syn match factorBinary /\/ +syn match factorHexErr /\/ +syn match factorHex /\/ +syn match factorOctErr /\/ +syn match factorOctal /\/ +syn match factorNan /\/ syn match factorIn /\/ syn match factorUse /\/ syn match factorUnuse /\/ -syn match factorCharErr /\/ +syn match factorChar /\/ syn match factorBackslash /\<\\\>\s\+\S\+\>/ +syn match factorLiteral /\<\$\>\s\+\S\+\>/ +syn region factorLiteralBlock start=/\<\$\[\>/ end=/\<\]\>/ syn region factorUsing start=/\/ end=/;/ +syn match factorQualified /\/ +syn match factorQualifiedWith /\/ +syn region factorFrom start=/\/ end=/;/ syn region factorSingletons start=/\/ end=/;/ syn match factorSymbol /\/ syn region factorSymbols start=/\/ end=/;/ syn region factorConstructor2 start=/\/ end=/\<;\>/ +syn region factorStruct start=/\<\(UNION-STRUCT:\|STRUCT:\)\>/ end=/\<;\>/ syn match factorConstant /\/ +syn match factorAlias /\/ syn match factorSingleton /\/ syn match factorPostpone /\/ syn match factorDefer /\/ @@ -112,10 +120,9 @@ syn match factorInstance /\/ syn match factorHook /\/ syn match factorMain /\/ syn match factorConstructor /\/ -syn match factorAlien /\/ - -syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor +syn match factorAlien /\/ +syn cluster factorWordOps contains=factorConstant,factorAlias,factorSingleton,factorSingletons,factorSymbol,factorSymbols,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor "TODO: "misc: @@ -125,24 +132,15 @@ syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer " PRIMITIVE: "C interface: -" FIELD: -" BEGIN-STRUCT: " C-ENUM: " FUNCTION: -" END-STRUCT -" DLL" " TYPEDEF: " LIBRARY: -" C-UNION: -"QUALIFIED: -"QUALIFIED-WITH: -"FROM: -"ALIAS: -"! POSTPONE: " "#\ " -syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline -syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline +syn region factorString start=/\<"/ skip=/\\"/ end=/"/ +syn region factorTriString start=/\<"""/ skip=/\\"/ end=/"""/ +syn region factorSbuf start=/\/ skip=/\\"/ end=/"/ syn region factorMultiString matchgroup=factorMultiStringDelims start=/\/ end=/^;$/ contains=factorMultiStringContents syn match factorMultiStringContents /.*/ contained @@ -158,30 +156,30 @@ if exists("g:factor_norainbow") syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL else syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1 - syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 - syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 - syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 - syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 - syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 - syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 - syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 - syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 - syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 + syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 + syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 + syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 + syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 + syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 + syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 + syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 + syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 + syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 endif if exists("g:factor_norainbow") - syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL + syn region factorArray matchgroup=factorDelimiter start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL else - syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 - syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 - syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 - syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 - syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 - syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 - syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 - syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 - syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 - syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\|\$\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 + syn region factorArray0 matchgroup=hlLevel0 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 + syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 + syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 + syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 + syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 + syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 + syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 + syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 + syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 + syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(\$\|[-a-zA-Z0-9]\+\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 endif syn match factorBracketErr /\<\]\>/ @@ -206,6 +204,7 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorConditional Conditional HiLink factorKeyword Keyword HiLink factorOperator Operator + HiLink factorFryDirective Operator HiLink factorBoolean Boolean HiLink factorDefnDelims Typedef HiLink factorMethodDelims Typedef @@ -219,6 +218,7 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorPGenericDelims Special HiLink factorPGenericNDelims Special HiLink factorString String + HiLink factorTriString String HiLink factorSbuf String HiLink factorMultiStringContents String HiLink factorMultiStringDelims Typedef @@ -229,18 +229,23 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorBinErr Error HiLink factorHex Number HiLink factorHexErr Error + HiLink factorNan Number HiLink factorOctal Number HiLink factorOctErr Error HiLink factorFloat Float HiLink factorInt Number HiLink factorUsing Include + HiLink factorQualified Include + HiLink factorQualifiedWith Include + HiLink factorFrom Include HiLink factorUse Include HiLink factorUnuse Include HiLink factorIn Define HiLink factorChar Character - HiLink factorCharErr Error HiLink factorDelimiter Delimiter HiLink factorBackslash Special + HiLink factorLiteral Special + HiLink factorLiteralBlock Special HiLink factorCompileDirective Typedef HiLink factorSymbol Define HiLink factorConstant Define @@ -255,6 +260,7 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorForget Define HiLink factorAlien Define HiLink factorTuple Typedef + HiLink factorStruct Typedef if &bg == "dark" hi hlLevel0 ctermfg=red guifg=red1 diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 340cdff032..1a6d9012ce 100644 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -23,7 +23,7 @@ else set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255 endif -syn cluster factorCluster contains=factorComment,factorFryDirective,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,factorLiteral,factorLiteralBlock,@factorWordOps,factorAlien,factorTuple,factorStruct +syn cluster factorCluster contains=factorComment,factorFryDirective,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorBackslash,factorLiteral,factorLiteralBlock,@factorWordOps,factorAlien,factorTuple,factorStruct syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained syn match factorComment /\<#!\>.*/ contains=factorTodo @@ -48,15 +48,14 @@ syn keyword factorBoolean f t syn match factorFryDirective /\<\(@\|_\)\>/ contained syn keyword factorCompileDirective inline foldable recursive -syn keyword factorKeyword boolean -syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean +syn keyword factorKeyword or 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry tri-curry* tri-curry@ swap and 2nip throw bi-curry (clone) hashcode* compose 2dip if 3tri unless compose? tuple keep 2curry equal? assert tri 2drop most boolean? identity-hashcode identity-tuple? null new dip bi-curry@ rot xor identity-tuple boolean syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map assoc assoc-map enum value-at* assoc-map-as >alist assoc-filter-as clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot -syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f -syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter! last-index-from reversed index-from cut* pad-tail (indices) concat-as remove-eq but-last snip trim-tail nths nth 2pusher sequence slice? partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length remove-eq! drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift remove! map-sum new-sequence follow like remove-nth! first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse! sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode member-eq? pop set-nth ?nth second map! join when-empty accumulator immutable-sequence? all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim +syn keyword factorKeyword number= if-zero next-power-of-2 each-integer ?1+ fp-special? imaginary-part unless-zero float>bits number? fp-infinity? bignum? fp-snan? denominator fp-bitwise= * + power-of-2? - u>= / >= bitand log2-expects-positive < log2 > integer? number bits>double 2/ zero? (find-integer) bits>float float? shift ratio? even? ratio fp-sign bitnot >fixnum complex? /i /f byte-array>bignum when-zero sgn >bignum next-float u< u> mod recip rational find-last-integer >float (all-integers?) 2^ times integer fixnum? neg fixnum sq bignum (each-integer) bit? fp-qnan? find-integer complex real double>bits bitor rem fp-nan-payload all-integers? real-part log2-expects-positive? prev-float align unordered? float fp-nan? abs bitxor u<= odd? <= /mod rational? >integer real? numerator +syn keyword factorKeyword member-eq? append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as last-index-from reversed index-from cut* pad-tail remove-eq! concat-as but-last snip trim-tail nths nth 2pusher sequence slice? partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length drop-prefix unclip unclip-last-slice iota map-sum bounds-error? sequence-hashcode-step pusher-for accumulate-as map start midpoint@ (accumulate) rest-slice prepend fourth sift accumulate! new-sequence follow map! like first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum suffix! insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? reverse! 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find filter! append-as reduce sequence= halves collapse-slice interleave 2map filter-as binary-reduce slice-error? product bounds-check? bounds-check harvest immutable virtual-exemplar find produce remove pad-head last replicate set-fourth remove-eq shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulator-for accumulate each pusher append! new-resizable cut-slice each-index head-slice* 2reverse-each sequence-hashcode pop set-nth ?nth second join when-empty accumulator immutable-sequence? all? 3append-as virtual-sequence subseq? remove-nth! push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum remove! glue slice-error subseq trim replace-slice push repetition map-index trim-head unclip-last mismatch syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc syn keyword factorKeyword 2array 3array pair >array 1array 4array pair? array resize-array array? -syn keyword factorKeyword +character+ bad-seek-type? readln stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* each-block output-stream stream-read-partial +syn keyword factorKeyword +character+ bad-seek-type? readln each-morsel stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents stream-tell tell-output bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* tell-input each-block output-stream stream-read-partial each-stream-block each-stream-line syn keyword factorKeyword resize-string >string 1string string string? syn keyword factorKeyword vector? ?push vector >vector 1vector syn keyword factorKeyword with-return restarts return-continuation with-datastack recover rethrow-restarts ifcc set-catchstack >continuation< cleanup ignore-errors restart? compute-restarts attempt-all-error error-thread continue attempt-all-error? condition? throw-restarts error catchstack continue-with thread-error-hook continuation rethrow callcc1 error-continuation callcc0 attempt-all condition continuation? restart return @@ -81,8 +80,7 @@ syn match factorIn /\/ syn match factorUse /\/ syn match factorUnuse /\/ -syn match factorCharErr /\/ +syn match factorChar /\/ syn match factorBackslash /\<\\\>\s\+\S\+\>/ syn match factorLiteral /\<\$\>\s\+\S\+\>/ @@ -232,7 +230,6 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorUnuse Include HiLink factorIn Define HiLink factorChar Character - HiLink factorCharErr Error HiLink factorDelimiter Delimiter HiLink factorBackslash Special HiLink factorLiteral Special From 67472040a9081e1f34b557f4c32f642e8d688e38 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 Jan 2010 11:32:21 -0800 Subject: [PATCH 05/72] adjust game.worlds docs language --- extra/game/worlds/worlds-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/game/worlds/worlds-docs.factor b/extra/game/worlds/worlds-docs.factor index c94126bfb0..47eb81c2fa 100644 --- a/extra/game/worlds/worlds-docs.factor +++ b/extra/game/worlds/worlds-docs.factor @@ -50,6 +50,6 @@ ARTICLE: "game.worlds" "Game worlds" end-game-world tick-game-world } -"Additionally, the standard " { $snippet "world" } " generics " { $link draw-world* } " and " { $link resize-world } " can also be given methods to draw the window contents and handle resize events. The " { $snippet "draw-world*" } " method will be invoked in a tight loop by the game loop." ; +"The standard " { $snippet "world" } " generics " { $link draw-world* } " and " { $link resize-world } " can also be given methods to draw the window contents and handle resize events. The " { $snippet "draw-world*" } " method will be invoked in a tight loop by the game loop to update the screen." ; ABOUT: "game.worlds" From 7a27d8a92b95709b1b26ac0c0c1dd35e73b8e7a3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 Jan 2010 11:35:02 -0800 Subject: [PATCH 06/72] audio.engine improvements: support static and streaming audio clips. let openal handle static sources to avoid factor timer vagaries. rename (audio-clip) to /, and to play-static-audio-clip/play-streaming-audio-clip --- extra/audio/engine/engine.factor | 158 +++++++++++++++++-------------- 1 file changed, 88 insertions(+), 70 deletions(-) diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index 176fc3c305..8ed461b604 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -56,10 +56,11 @@ M: audio-listener audio-gain gain>> ; inline M: audio-listener audio-velocity velocity>> ; inline M: audio-listener audio-orientation orientation>> ; inline +GENERIC# generate-audio 1 ( generator buffer-size -- c-ptr ) +GENERIC: generator-audio-format ( generator -- channels sample-bits sample-rate ) + TUPLE: audio-engine < disposable { voice-count integer } - { buffer-size integer } - { buffer-count integer } { al-device c-ptr } { al-context c-ptr } al-sources @@ -70,17 +71,24 @@ TUPLE: audio-engine < disposable TUPLE: audio-clip < disposable { audio-engine audio-engine } - { audio audio } source - { loop? boolean } - { al-source integer } - { al-buffers uint-array } - { next-data-offset integer } ; + { al-source integer } ; + +TUPLE: static-audio-clip < audio-clip + { al-buffer integer } ; + +TUPLE: streaming-audio-clip < audio-clip + generator + { buffer-size integer } + { channels integer } + { sample-bits integer } + { sample-rate integer } + { al-buffers uint-array } ; ERROR: audio-device-not-found device-name ; ERROR: audio-context-not-available device-name ; -:: ( device-name voice-count buffer-size buffer-count -- engine ) +:: ( device-name voice-count -- engine ) [ device-name alcOpenDevice :> al-device al-device [ device-name audio-device-not-found ] unless @@ -96,12 +104,10 @@ ERROR: audio-context-not-available device-name ; voice-count >>voice-count al-device >>al-device al-context >>al-context - buffer-size >>buffer-size - buffer-count >>buffer-count ] with-destructors ; : ( -- engine ) - f 16 8192 2 ; + f 16 ; > dup (uint-array) [ alGenSources ] keep ; inline -:: flush-source ( source -- ) - source alSourceStop +:: flush-source ( al-source -- ) + al-source alSourceStop 0 c: :> dummy-buffer - source AL_BUFFERS_PROCESSED get-source-param [ - source 1 dummy-buffer alSourceUnqueueBuffers - ] times ; + al-source AL_BUFFERS_PROCESSED get-source-param [ + al-source 1 dummy-buffer alSourceUnqueueBuffers + ] times + al-source AL_BUFFER 0 alSourcei ; : free-sources ( sources -- ) [ length ] keep alDeleteSources ; inline @@ -148,37 +155,13 @@ ERROR: audio-context-not-available device-name ; audio-clip [ size + ] change-next-data-offset drop ; inline :: queue-clip-buffer ( audio-clip al-buffer -- ) - audio-clip audio-engine>> :> audio-engine - audio-engine buffer-size>> :> buffer-size - audio-clip audio>> :> audio - audio-clip next-data-offset>> :> next-data-offset - audio size>> next-data-offset - :> remaining-audio + audio-clip al-source>> :> al-source + audio-clip generator>> :> generator + audio-clip buffer-size>> :> buffer-size + generator buffer-size generate-audio :> data - { - { [ remaining-audio 0 <= ] [ - audio-clip loop?>> [ - audio-clip 0 >>next-data-offset - al-buffer queue-clip-buffer - ] when - ] } - { [ remaining-audio buffer-size < ] [ - audio-clip loop?>> [ - audio data>> - [ next-data-offset swap remaining-audio ] - [ buffer-size remaining-audio - ] bi append :> data - audio-clip al-buffer audio data buffer-size (queue-clip-buffer) - - audio-clip [ audio size>> mod ] change-next-data-offset drop - ] [ - next-data-offset audio data>> :> data - audio-clip al-buffer audio data remaining-audio (queue-clip-buffer) - ] if - ] } - [ - next-data-offset audio data>> :> data - audio-clip al-buffer audio data buffer-size (queue-clip-buffer) - ] - } cond ; + al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData + al-source 1 al-buffer c: alSourceQueueBuffers ; : update-listener ( audio-engine -- ) listener>> { @@ -198,18 +181,24 @@ ERROR: audio-context-not-available device-name ; [ AL_ROLLOFF_FACTOR swap audio-rolloff alSourcef ] } 2cleave ; -:: update-audio-clip ( audio-clip -- ) - audio-clip update-source - audio-clip al-source>> :> al-source - 0 c: :> buffer* +GENERIC: (update-audio-clip) ( audio-clip -- ) - al-source AL_SOURCE_STATE get-source-param AL_STOPPED = - [ audio-clip dispose ] [ - al-source AL_BUFFERS_PROCESSED get-source-param [ - al-source 1 buffer* alSourceUnqueueBuffers - audio-clip buffer* c:*uint queue-clip-buffer - ] times - ] if ; +M: static-audio-clip (update-audio-clip) + drop ; + +M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- ) + audio-clip al-source>> :> al-source + 0 c: :> buffer + al-source AL_BUFFERS_PROCESSED get-source-param [ + al-source 1 buffer alSourceUnqueueBuffers + audio-clip buffer c:*uint queue-clip-buffer + ] times ; + +: update-audio-clip ( audio-clip -- ) + [ update-source ] [ + dup al-source>> AL_SOURCE_STATE get-source-param AL_STOPPED = + [ dispose ] [ (update-audio-clip) ] if + ] bi ; : clip-al-sources ( clips -- length sources ) [ length ] [ [ al-source>> ] uint-array{ } map-as ] bi ; @@ -261,33 +250,59 @@ M: audio-engine dispose* [ [ alcCloseDevice* ] when* f ] change-al-device drop ; -:: (audio-clip) ( audio-engine audio source loop? -- audio-clip/f ) +:: ( audio-engine audio source loop? -- audio-clip/f ) + audio-engine get-available-source :> al-source + + al-source [ + 1 0 c: [ alGenBuffers ] keep c:*uint :> al-buffer + al-buffer audio { [ openal-format ] [ data>> ] [ size>> ] [ sample-rate>> ] } cleave + alBufferData + + al-source AL_BUFFER al-buffer alSourcei + al-source AL_LOOPING loop? c:>c-bool alSourcei + + static-audio-clip new-disposable + audio-engine >>audio-engine + source >>source + al-source >>al-source + al-buffer >>al-buffer :> clip + clip audio-engine clips>> push + clip + ] [ f ] if ; + +:: ( audio-engine source generator buffer-size buffer-count -- audio-clip/f ) audio-engine get-available-source :> al-source al-source [ - audio-engine buffer-count>> :> buffer-count buffer-count dup (uint-array) [ alGenBuffers ] keep :> al-buffers + generator generator-audio-format :> ( channels sample-bits sample-rate ) audio-clip new-disposable audio-engine >>audio-engine - audio >>audio source >>source - loop? >>loop? al-source >>al-source + generator >>generator + buffer-size >>buffer-size + channels >>channels + sample-bits >>sample-bits + sample-rate >>sample-rate al-buffers >>al-buffers - 0 >>next-data-offset :> clip al-buffers [ clip swap queue-clip-buffer ] each clip audio-engine clips>> push - clip ] [ f ] if ; M: audio-clip dispose* - { - [ al-source>> flush-source ] - [ al-buffers>> [ length ] keep alDeleteBuffers ] - [ dup audio-engine>> clips>> remove! drop ] - } cleave ; + [ audio-engine>> clips>> remove! drop ] + [ al-source>> flush-source ] bi ; + +M: static-audio-clip dispose* + [ call-next-method ] + [ [ 1 ] dip al-buffer>> alDeleteBuffers ] bi ; + +M: streaming-audio-clip dispose* + [ call-next-method ] + [ al-buffers>> [ length ] keep alDeleteBuffers ] bi ; : play-clip ( audio-clip -- ) [ update-source ] @@ -297,8 +312,11 @@ M: audio-clip dispose* [ [ update-source ] each ] [ clip-al-sources alSourcePlayv ] bi ; -: ( audio-engine audio source loop? -- audio-clip/f ) - (audio-clip) dup play-clip ; +: play-static-audio-clip ( audio-engine source audio loop? -- audio-clip/f ) + dup [ play-clip ] when* ; + +: play-streaming-audio-clip ( audio-engine source generator buffer-size buffer-count -- audio-clip/f ) + dup [ play-clip ] when* ; : pause-clip ( audio-clip -- ) al-source>> alSourcePause ; From 8f9b5b8bc72e91616c2ce407e7c6771e78b464f8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 Jan 2010 11:36:52 -0800 Subject: [PATCH 07/72] update audio.engine.test for audio.engine changes --- extra/audio/engine/test/test.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/audio/engine/test/test.factor b/extra/audio/engine/test/test.factor index 59834a9fb2..c81e7367c6 100644 --- a/extra/audio/engine/test/test.factor +++ b/extra/audio/engine/test/test.factor @@ -9,8 +9,8 @@ IN: audio.engine.test 0 :> i! :> engine engine start-audio* - engine loop-sound T{ audio-source f { 1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } t - :> loop-clip + engine loop-sound T{ audio-source f { 1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } t + play-static-audio-clip :> loop-clip [ i 1 + i! @@ -19,7 +19,7 @@ IN: audio.engine.test i 50 mod zero? [ engine once-sound T{ audio-source f { 0.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } f - drop + play-static-audio-clip drop ] when engine update-audio From 92409fd3b66110b58d3d3bb38a66182c754f7d62 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 Jan 2010 11:40:13 -0800 Subject: [PATCH 08/72] mop up dead code and other debris from audio.engine --- extra/audio/engine/engine.factor | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index 8ed461b604..5bf8bd9282 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -148,19 +148,13 @@ ERROR: audio-context-not-available device-name ; audio-engine next-source >>next-source drop al-source ; -:: (queue-clip-buffer) ( audio-clip al-buffer audio data size -- ) - al-buffer audio openal-format data size audio sample-rate>> alBufferData - audio-clip al-source>> 1 al-buffer c: alSourceQueueBuffers - - audio-clip [ size + ] change-next-data-offset drop ; inline - :: queue-clip-buffer ( audio-clip al-buffer -- ) audio-clip al-source>> :> al-source audio-clip generator>> :> generator audio-clip buffer-size>> :> buffer-size generator buffer-size generate-audio :> data - al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData + al-buffer audio-clip openal-format data buffer-size audio-clip sample-rate>> alBufferData al-source 1 al-buffer c: alSourceQueueBuffers ; : update-listener ( audio-engine -- ) @@ -265,7 +259,8 @@ M: audio-engine dispose* audio-engine >>audio-engine source >>source al-source >>al-source - al-buffer >>al-buffer :> clip + al-buffer >>al-buffer + :> clip clip audio-engine clips>> push clip ] [ f ] if ; @@ -287,18 +282,19 @@ M: audio-engine dispose* sample-bits >>sample-bits sample-rate >>sample-rate al-buffers >>al-buffers + :> clip al-buffers [ clip swap queue-clip-buffer ] each clip audio-engine clips>> push clip ] [ f ] if ; M: audio-clip dispose* - [ audio-engine>> clips>> remove! drop ] + [ dup audio-engine>> clips>> remove! drop ] [ al-source>> flush-source ] bi ; M: static-audio-clip dispose* [ call-next-method ] - [ [ 1 ] dip al-buffer>> alDeleteBuffers ] bi ; + [ [ 1 ] dip al-buffer>> c: alDeleteBuffers ] bi ; M: streaming-audio-clip dispose* [ call-next-method ] From 87c09af8f339dfaea853798587c22e5b9e73b3cb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 Jan 2010 11:44:18 -0800 Subject: [PATCH 09/72] update game.worlds and gpu.demo.raytrace for audio.engine changes --- extra/game/worlds/worlds-docs.factor | 2 -- extra/game/worlds/worlds.factor | 10 +--------- extra/gpu/demos/raytrace/raytrace.factor | 9 ++++----- 3 files changed, 5 insertions(+), 16 deletions(-) diff --git a/extra/game/worlds/worlds-docs.factor b/extra/game/worlds/worlds-docs.factor index 47eb81c2fa..c10ae40561 100644 --- a/extra/game/worlds/worlds-docs.factor +++ b/extra/game/worlds/worlds-docs.factor @@ -11,8 +11,6 @@ HELP: game-attributes { { $snippet "use-audio-engine?" } " specifies whether the game world should manage an " { $link audio-engine } " instance. False by default." } { { $snippet "audio-engine-device" } " specifies the string name of the OpenAL device the audio engine, if any, should try to open. The default value of " { $link POSTPONE: f } " attempts to open the default OpenAL device." } { { $snippet "audio-engine-voice-count" } " determines the number of independent voices the audio engine will make available. This determines how many individual audio clips can play simultaneously. This cannot exceed the OpenAL implementation's limit on supported voices." } -{ { $snippet "audio-engine-buffer-size" } " determines the size in bytes of the audio buffers the audio engine will stream to the sound card." } -{ { $snippet "audio-engine-buffer-count" } " determines the number of buffers the audio engine will allocate per audio clip played." } } ; HELP: game-world diff --git a/extra/game/worlds/worlds.factor b/extra/game/worlds/worlds.factor index cf75d37b39..dd9b2431c9 100644 --- a/extra/game/worlds/worlds.factor +++ b/extra/game/worlds/worlds.factor @@ -12,8 +12,6 @@ TUPLE: game-world < world { use-audio-engine? boolean } { audio-engine-device initial: f } { audio-engine-voice-count initial: 16 } - { audio-engine-buffer-size initial: 8192 } - { audio-engine-buffer-count initial: 2 } { tick-slice float initial: 0.0 } ; GENERIC: begin-game-world ( world -- ) @@ -38,8 +36,6 @@ M: game-world draw* { [ audio-engine-device>> ] [ audio-engine-voice-count>> ] - [ audio-engine-buffer-size>> ] - [ audio-engine-buffer-count>> ] } cleave [ start-audio* ] keep ; inline @@ -63,9 +59,7 @@ TUPLE: game-attributes < world-attributes { use-game-input? boolean initial: f } { use-audio-engine? boolean initial: f } { audio-engine-device initial: f } - { audio-engine-voice-count initial: 16 } - { audio-engine-buffer-size initial: 8192 } - { audio-engine-buffer-count initial: 2 } ; + { audio-engine-voice-count initial: 16 } ; M: game-world apply-world-attributes { @@ -74,8 +68,6 @@ M: game-world apply-world-attributes [ use-audio-engine?>> >>use-audio-engine? ] [ audio-engine-device>> >>audio-engine-device ] [ audio-engine-voice-count>> >>audio-engine-voice-count ] - [ audio-engine-buffer-size>> >>audio-engine-buffer-size ] - [ audio-engine-buffer-count>> >>audio-engine-buffer-count ] [ call-next-method ] } cleave ; diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor index 54912544f1..5dcd5eeedc 100644 --- a/extra/gpu/demos/raytrace/raytrace.factor +++ b/extra/gpu/demos/raytrace/raytrace.factor @@ -79,13 +79,13 @@ CONSTANT: initial-spheres { audio-engine world >>listener update-audio audio-engine "vocab:gpu/demos/raytrace/mirror-ball.aiff" read-audio - spheres first t (audio-clip) + spheres first t audio-engine "vocab:gpu/demos/raytrace/red-ball.aiff" read-audio - spheres second t (audio-clip) + spheres second t audio-engine "vocab:gpu/demos/raytrace/green-ball.aiff" read-audio - spheres third t (audio-clip) + spheres third t audio-engine "vocab:gpu/demos/raytrace/yellow-ball.aiff" read-audio - spheres fourth t (audio-clip) + spheres fourth t 4array play-clips ; @@ -124,7 +124,6 @@ GAME: raytrace-game { { grab-input? t } { use-game-input? t } { use-audio-engine? t } - { audio-engine-buffer-count 4 } { pref-dim { 1024 768 } } { tick-interval-micros $[ 60 fps ] } } ; From 6b8c5bd1015ba67208a448132a9ed1d3252644b6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 Jan 2010 11:48:48 -0800 Subject: [PATCH 10/72] tweak audio.engine generator interface --- extra/audio/engine/engine.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index 5bf8bd9282..28b4900c85 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -56,7 +56,7 @@ M: audio-listener audio-gain gain>> ; inline M: audio-listener audio-velocity velocity>> ; inline M: audio-listener audio-orientation orientation>> ; inline -GENERIC# generate-audio 1 ( generator buffer-size -- c-ptr ) +GENERIC# generate-audio 1 ( generator buffer-size -- c-ptr size ) GENERIC: generator-audio-format ( generator -- channels sample-bits sample-rate ) TUPLE: audio-engine < disposable @@ -152,10 +152,12 @@ ERROR: audio-context-not-available device-name ; audio-clip al-source>> :> al-source audio-clip generator>> :> generator audio-clip buffer-size>> :> buffer-size - generator buffer-size generate-audio :> data + generator buffer-size generate-audio :> ( data size ) - al-buffer audio-clip openal-format data buffer-size audio-clip sample-rate>> alBufferData - al-source 1 al-buffer c: alSourceQueueBuffers ; + data [ + al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData + al-source 1 al-buffer c: alSourceQueueBuffers + ] when ; : update-listener ( audio-engine -- ) listener>> { From 90a065e690059f81ea76a75789d20197140628ee Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 Jan 2010 12:26:07 -0800 Subject: [PATCH 11/72] rearrange order of args to be consistent with . add a streaming noise generator to audio.engine.test to ensure streaming clips work --- extra/audio/engine/engine.factor | 5 +++-- extra/audio/engine/test/test.factor | 25 ++++++++++++++++++------ extra/gpu/demos/raytrace/raytrace.factor | 16 +++++++-------- 3 files changed, 30 insertions(+), 16 deletions(-) diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index 28b4900c85..91acd70401 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -183,6 +183,7 @@ M: static-audio-clip (update-audio-clip) drop ; M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- ) + "blip" P drop audio-clip al-source>> :> al-source 0 c: :> buffer al-source AL_BUFFERS_PROCESSED get-source-param [ @@ -246,7 +247,7 @@ M: audio-engine dispose* [ [ alcCloseDevice* ] when* f ] change-al-device drop ; -:: ( audio-engine audio source loop? -- audio-clip/f ) +:: ( audio-engine source audio loop? -- audio-clip/f ) audio-engine get-available-source :> al-source al-source [ @@ -274,7 +275,7 @@ M: audio-engine dispose* buffer-count dup (uint-array) [ alGenBuffers ] keep :> al-buffers generator generator-audio-format :> ( channels sample-bits sample-rate ) - audio-clip new-disposable + streaming-audio-clip new-disposable audio-engine >>audio-engine source >>source al-source >>al-source diff --git a/extra/audio/engine/test/test.factor b/extra/audio/engine/test/test.factor index c81e7367c6..8f3a94050a 100644 --- a/extra/audio/engine/test/test.factor +++ b/extra/audio/engine/test/test.factor @@ -1,24 +1,38 @@ ! (c)2009 Joe Groff bsd license USING: accessors alarms audio audio.engine audio.loader calendar -destructors io kernel locals math math.functions ; +destructors io kernel locals math math.functions math.ranges specialized-arrays +sequences random math.vectors ; +FROM: alien.c-types => short ; +SPECIALIZED-ARRAY: short IN: audio.engine.test +TUPLE: noise-generator ; + +M: noise-generator generator-audio-format + drop 1 16 8000 ; +M: noise-generator generate-audio + nip P [ -1 shift [ -4096 4096 [a,b] random ] short-array{ } replicate-as ] keep ; + :: audio-engine-test ( -- ) "vocab:audio/engine/test/loop.aiff" read-audio :> loop-sound "vocab:audio/engine/test/once.wav" read-audio :> once-sound 0 :> i! :> engine engine start-audio* - engine loop-sound T{ audio-source f { 1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } t + + engine T{ audio-source f { 1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } loop-sound t play-static-audio-clip :> loop-clip + engine T{ audio-source f { -1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } noise-generator new 8192 2 + play-streaming-audio-clip :> noise-clip [ i 1 + i! - i 0.05 * sin :> s - loop-clip source>> { s 0.0 0.0 } >>position drop + i 0.05 * [ sin ] [ cos ] bi :> ( s c ) + loop-clip source>> { c 0.0 s } >>position drop + noise-clip source>> { c 0.0 s } -2.0 v*n >>position drop i 50 mod zero? [ - engine once-sound T{ audio-source f { 0.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } f + engine T{ audio-source f { 0.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } once-sound f play-static-audio-clip drop ] when @@ -29,5 +43,4 @@ IN: audio.engine.test alarm cancel-alarm engine dispose ; - MAIN: audio-engine-test diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor index 5dcd5eeedc..634d7a2fd9 100644 --- a/extra/gpu/demos/raytrace/raytrace.factor +++ b/extra/gpu/demos/raytrace/raytrace.factor @@ -78,14 +78,14 @@ CONSTANT: initial-spheres { audio-engine world >>listener update-audio - audio-engine "vocab:gpu/demos/raytrace/mirror-ball.aiff" read-audio - spheres first t - audio-engine "vocab:gpu/demos/raytrace/red-ball.aiff" read-audio - spheres second t - audio-engine "vocab:gpu/demos/raytrace/green-ball.aiff" read-audio - spheres third t - audio-engine "vocab:gpu/demos/raytrace/yellow-ball.aiff" read-audio - spheres fourth t + audio-engine spheres first + "vocab:gpu/demos/raytrace/mirror-ball.aiff" read-audio t + audio-engine spheres second + "vocab:gpu/demos/raytrace/red-ball.aiff" read-audio t + audio-engine spheres third + "vocab:gpu/demos/raytrace/green-ball.aiff" read-audio t + audio-engine spheres fourth + "vocab:gpu/demos/raytrace/yellow-ball.aiff" read-audio t 4array play-clips ; From d58ac131012fba1e2434548b07dccb5ad4ab7488 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 Jan 2010 15:23:48 -0800 Subject: [PATCH 12/72] remove debug prints --- extra/audio/engine/engine.factor | 1 - extra/audio/engine/test/test.factor | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index 91acd70401..3bc81cd681 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -183,7 +183,6 @@ M: static-audio-clip (update-audio-clip) drop ; M:: streaming-audio-clip (update-audio-clip) ( audio-clip -- ) - "blip" P drop audio-clip al-source>> :> al-source 0 c: :> buffer al-source AL_BUFFERS_PROCESSED get-source-param [ diff --git a/extra/audio/engine/test/test.factor b/extra/audio/engine/test/test.factor index 8f3a94050a..46c45f84b1 100644 --- a/extra/audio/engine/test/test.factor +++ b/extra/audio/engine/test/test.factor @@ -11,7 +11,7 @@ TUPLE: noise-generator ; M: noise-generator generator-audio-format drop 1 16 8000 ; M: noise-generator generate-audio - nip P [ -1 shift [ -4096 4096 [a,b] random ] short-array{ } replicate-as ] keep ; + nip [ -1 shift [ -4096 4096 [a,b] random ] short-array{ } replicate-as ] keep ; :: audio-engine-test ( -- ) "vocab:audio/engine/test/loop.aiff" read-audio :> loop-sound From 97668156d991615e9ebe40835f8a59e93a9fa80e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 21 Jan 2010 05:02:39 -0600 Subject: [PATCH 13/72] NetBSD 64 blas abi changed --- basis/math/blas/config/config.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/math/blas/config/config.factor b/basis/math/blas/config/config.factor index 09f736c036..bce6e663af 100644 --- a/basis/math/blas/config/config.factor +++ b/basis/math/blas/config/config.factor @@ -15,7 +15,6 @@ blas-fortran-abi [ { { [ os macosx? ] [ intel-unix-abi ] } { [ os windows? cpu x86.32? and ] [ f2c-abi ] } - { [ os netbsd? cpu x86.64? and ] [ g95-abi ] } { [ os windows? cpu x86.64? and ] [ gfortran-abi ] } { [ os freebsd? ] [ gfortran-abi ] } { [ os linux? ] [ gfortran-abi ] } From de9dad0f08d7d21a1f4c5cbff92fcfe5cb88aa79 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 21 Jan 2010 10:41:11 -0800 Subject: [PATCH 14/72] make sure VAOs are available to gpu library --- extra/gpu/gpu.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/gpu/gpu.factor b/extra/gpu/gpu.factor index 12c6801439..6a61e2ec4f 100644 --- a/extra/gpu/gpu.factor +++ b/extra/gpu/gpu.factor @@ -11,6 +11,8 @@ VARIANT: gpu-api : set-gpu-api ( -- ) "2.0" require-gl-version + "3.0" { { "GL_ARB_vertex_array_object" "GL_APPLE_vertex_array_object" } } + require-gl-version-or-extensions "3.0" has-gl-version? opengl-3 opengl-2 ? gpu-api set-global ; HOOK: init-gpu-api gpu-api ( -- ) From 77385e8715b0ba3475034f616ff3c713dba9e2a1 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 21 Jan 2010 11:13:34 -0800 Subject: [PATCH 15/72] generalize vim syntax highlighting for SBUF" " to any syntax word ending in " --- misc/vim/syntax/factor.vim | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 1a6d9012ce..ba9efa91fb 100644 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -128,7 +128,7 @@ syn cluster factorWordOps contains=factorConstant,factorAlias,factorSingle syn region factorString start=/\<"/ skip=/\\"/ end=/"/ syn region factorTriString start=/\<"""/ skip=/\\"/ end=/"""/ -syn region factorSbuf start=/\/ skip=/\\"/ end=/"/ +syn region factorSbuf start=/\<[-a-zA-Z0-9]\+"\>/ skip=/\\"/ end=/"/ syn region factorMultiString matchgroup=factorMultiStringDelims start=/\/ end=/^;$/ contains=factorMultiStringContents syn match factorMultiStringContents /.*/ contained From 407399b86a4c2d64aa66d4d6676380d224954158 Mon Sep 17 00:00:00 2001 From: erikc Date: Thu, 21 Jan 2010 18:39:23 -0800 Subject: [PATCH 16/72] Add iota call in game.input.dinput fill-mouse-state. --- basis/game/input/dinput/dinput.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/game/input/dinput/dinput.factor b/basis/game/input/dinput/dinput.factor index d3540a99a9..e2c1fda759 100755 --- a/basis/game/input/dinput/dinput.factor +++ b/basis/game/input/dinput/dinput.factor @@ -314,7 +314,7 @@ CONSTANT: pov-values } case ; : fill-mouse-state ( buffer count -- state ) - [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ; + iota [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ; : get-device-state ( device DIJOYSTATE2 -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip From d63c2fefc97070c2b63e4e63578f9d95b66b39bd Mon Sep 17 00:00:00 2001 From: erikc Date: Thu, 21 Jan 2010 23:33:37 -0800 Subject: [PATCH 17/72] Fix missing vocab USINGs and mispelled d2dbasetypes --- basis/windows/directx/d2d1/d2d1.factor | 2 +- basis/windows/directx/d2dbasetypes/d2dbasetypes.factor | 2 +- basis/windows/directx/d3d11shader/d3d11shader.factor | 3 ++- basis/windows/directx/d3dx10mesh/d3dx10mesh.factor | 2 +- 4 files changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/windows/directx/d2d1/d2d1.factor b/basis/windows/directx/d2d1/d2d1.factor index fad88787f3..cf9e5a3a98 100644 --- a/basis/windows/directx/d2d1/d2d1.factor +++ b/basis/windows/directx/d2d1/d2d1.factor @@ -1,5 +1,5 @@ USING: alien.c-types alien.syntax classes.struct windows.com -windows.com.syntax windows.directx.d3dbasetypes windows.directx.dcommon +windows.com.syntax windows.directx.d2dbasetypes windows.directx.dcommon windows.directx.dxgi windows.directx.dxgiformat windows.ole32 windows.types ; IN: windows.directx.d2d1 diff --git a/basis/windows/directx/d2dbasetypes/d2dbasetypes.factor b/basis/windows/directx/d2dbasetypes/d2dbasetypes.factor index 00f84e9750..3cdb0bbe32 100644 --- a/basis/windows/directx/d2dbasetypes/d2dbasetypes.factor +++ b/basis/windows/directx/d2dbasetypes/d2dbasetypes.factor @@ -1,5 +1,5 @@ USING: alien.syntax classes.struct windows.types ; -IN: windows.directx.d3dbasetypes +IN: windows.directx.d2dbasetypes STRUCT: D3DCOLORVALUE { r FLOAT } diff --git a/basis/windows/directx/d3d11shader/d3d11shader.factor b/basis/windows/directx/d3d11shader/d3d11shader.factor index beb5392e37..a0437e3e65 100644 --- a/basis/windows/directx/d3d11shader/d3d11shader.factor +++ b/basis/windows/directx/d3d11shader/d3d11shader.factor @@ -1,6 +1,7 @@ USING: alien.syntax alien.c-types classes.struct windows.types windows.directx.d3d10shader windows.directx.d3d10 -windows.directx.d3d11 windows.com windows.com.syntax ; +windows.directx.d3d11 windows.com windows.com.syntax +windows.directx.d3dcommon ; IN: windows.directx.d3d11shader LIBRARY: d3d11 diff --git a/basis/windows/directx/d3dx10mesh/d3dx10mesh.factor b/basis/windows/directx/d3dx10mesh/d3dx10mesh.factor index 13066dcdec..9eb563e60c 100644 --- a/basis/windows/directx/d3dx10mesh/d3dx10mesh.factor +++ b/basis/windows/directx/d3dx10mesh/d3dx10mesh.factor @@ -1,6 +1,6 @@ USING: alien.c-types alien.syntax classes.struct windows.com windows.com.syntax windows.directx.d3d10 -windows.directx.d3d10misc windows.types ; +windows.directx.d3d10misc windows.types windows.directx.d3dx10math ; IN: windows.directx.d3dx10mesh LIBRARY: d3dx10 From 638fbb13b026bccbfd61570b926a331cccec1efa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 Jan 2010 23:14:20 +1300 Subject: [PATCH 18/72] alien.c-types: clean up and fix for win64 --- basis/alien/c-types/c-types.factor | 114 ++++++++++++++++------------- 1 file changed, 63 insertions(+), 51 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 347d157a79..ff17e68e83 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -348,52 +348,6 @@ SYMBOLS: "alien_offset" >>unboxer \ void* define-primitive-type - - integer >>class - integer >>boxed-class - [ alien-signed-8 ] >>getter - [ set-alien-signed-8 ] >>setter - 8 >>size - 8-byte-alignment - "from_signed_8" >>boxer - "to_signed_8" >>unboxer - \ longlong define-primitive-type - - - integer >>class - integer >>boxed-class - [ alien-unsigned-8 ] >>getter - [ set-alien-unsigned-8 ] >>setter - 8 >>size - 8-byte-alignment - "from_unsigned_8" >>boxer - "to_unsigned_8" >>unboxer - \ ulonglong define-primitive-type - - - integer >>class - integer >>boxed-class - [ alien-signed-cell ] >>getter - [ set-alien-signed-cell ] >>setter - bootstrap-cell >>size - bootstrap-cell >>align - bootstrap-cell >>align-first - "from_signed_cell" >>boxer - "to_fixnum" >>unboxer - \ long define-primitive-type - - - integer >>class - integer >>boxed-class - [ alien-unsigned-cell ] >>getter - [ set-alien-unsigned-cell ] >>setter - bootstrap-cell >>size - bootstrap-cell >>align - bootstrap-cell >>align-first - "from_unsigned_cell" >>boxer - "to_cell" >>unboxer - \ ulong define-primitive-type - integer >>class integer >>boxed-class @@ -514,16 +468,74 @@ SYMBOLS: [ >float ] >>unboxer-quot \ double define-primitive-type - cpu x86.64? os windows? and [ + cell 8 = [ + + integer >>class + integer >>boxed-class + [ alien-signed-cell ] >>getter + [ set-alien-signed-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + bootstrap-cell >>align-first + "from_signed_cell" >>boxer + "to_fixnum" >>unboxer + \ longlong define-primitive-type + + + integer >>class + integer >>boxed-class + [ alien-unsigned-cell ] >>getter + [ set-alien-unsigned-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + bootstrap-cell >>align-first + "from_unsigned_cell" >>boxer + "to_cell" >>unboxer + \ ulonglong define-primitive-type + + os windows? [ + \ int c-type \ long typedef + \ uint c-type \ ulong typedef + ] [ + \ longlong c-type \ long typedef + \ ulonglong c-type \ ulong typedef + ] if + \ longlong c-type \ ptrdiff_t typedef \ longlong c-type \ intptr_t typedef + \ ulonglong c-type \ uintptr_t typedef \ ulonglong c-type \ size_t typedef ] [ - \ long c-type \ ptrdiff_t typedef - \ long c-type \ intptr_t typedef - \ ulong c-type \ uintptr_t typedef - \ ulong c-type \ size_t typedef + + integer >>class + integer >>boxed-class + [ alien-signed-8 ] >>getter + [ set-alien-signed-8 ] >>setter + 8 >>size + 8-byte-alignment + "from_signed_8" >>boxer + "to_signed_8" >>unboxer + \ longlong define-primitive-type + + + integer >>class + integer >>boxed-class + [ alien-unsigned-8 ] >>getter + [ set-alien-unsigned-8 ] >>setter + 8 >>size + 8-byte-alignment + "from_unsigned_8" >>boxer + "to_unsigned_8" >>unboxer + \ ulonglong define-primitive-type + + \ int c-type \ long typedef + \ int c-type \ ptrdiff_t typedef + \ int c-type \ intptr_t typedef + + \ uint c-type \ ulong typedef + \ uint c-type \ uintptr_t typedef + \ uint c-type \ size_t typedef ] if ] with-compilation-unit From 892522f8bda205c85a82aec475b1950f45f36b32 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Jan 2010 00:15:08 +1300 Subject: [PATCH 19/72] alien.c-types: ensure that long and ulong types are defined with define-primitive-type and not typedef --- basis/alien/c-types/c-types.factor | 13 +++++++------ basis/cpu/x86/x86.factor | 4 ++-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index ff17e68e83..24221160ce 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -494,11 +494,11 @@ SYMBOLS: \ ulonglong define-primitive-type os windows? [ - \ int c-type \ long typedef - \ uint c-type \ ulong typedef + \ int c-type \ long define-primitive-type + \ uint c-type \ ulong define-primitive-type ] [ - \ longlong c-type \ long typedef - \ ulonglong c-type \ ulong typedef + \ longlong c-type \ long define-primitive-type + \ ulonglong c-type \ ulong define-primitive-type ] if \ longlong c-type \ ptrdiff_t typedef @@ -529,11 +529,12 @@ SYMBOLS: "to_unsigned_8" >>unboxer \ ulonglong define-primitive-type - \ int c-type \ long typedef + \ int c-type \ long define-primitive-type + \ uint c-type \ ulong define-primitive-type + \ int c-type \ ptrdiff_t typedef \ int c-type \ intptr_t typedef - \ uint c-type \ ulong typedef \ uint c-type \ uintptr_t typedef \ uint c-type \ size_t typedef ] if diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index f2751b1be2..0cd557896b 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -56,8 +56,8 @@ M: x86 stack-frame-size ( stack-frame -- i ) 3 cells + align-stack ; -! Must be a volatile register not used for parameter passing, for safe -! use in calls in and out of C +! Must be a volatile register not used for parameter passing or +! integer return HOOK: temp-reg cpu ( -- reg ) HOOK: pic-tail-reg cpu ( -- reg ) From f804c9c4222ff86e2defdc05d7cfb695918c69e2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Jan 2010 00:39:56 +1300 Subject: [PATCH 20/72] Move compile-call and related words only meant to be used for debugging to compiler.test --- basis/cocoa/cocoa-tests.factor | 2 +- basis/compiler/compiler-docs.factor | 11 +---------- basis/compiler/compiler.factor | 13 +------------ basis/compiler/test/authors.txt | 1 + basis/compiler/test/test.factor | 19 +++++++++++++++++++ basis/compiler/tests/codegen.factor | 2 +- basis/compiler/tests/curry.factor | 2 +- basis/compiler/tests/float.factor | 5 +++-- basis/compiler/tests/intrinsics.factor | 2 +- basis/compiler/tests/optimizer.factor | 2 +- basis/compiler/tests/simple.factor | 2 +- basis/compiler/tests/tuples.factor | 2 +- basis/math/floats/env/env-tests.factor | 4 ++-- .../conversion/conversion-tests.factor | 2 +- basis/math/vectors/simd/simd-tests.factor | 2 +- basis/tools/profiler/profiler-tests.factor | 2 +- basis/tools/time/time-tests.factor | 2 +- 17 files changed, 38 insertions(+), 37 deletions(-) create mode 100644 basis/compiler/test/authors.txt create mode 100644 basis/compiler/test/test.factor diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index 892d5ea38d..f35d151ad4 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -1,5 +1,5 @@ USING: cocoa cocoa.messages cocoa.subclassing cocoa.types -compiler kernel namespaces cocoa.classes cocoa.runtime +compiler.test kernel namespaces cocoa.classes cocoa.runtime tools.test memory compiler.units math core-graphics.types ; FROM: alien.c-types => int void ; IN: cocoa.tests diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index f59d4fb027..42d4edcc10 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -16,11 +16,7 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler" disable-optimizer enable-optimizer } -"Removing a word's optimized definition:" -{ $subsections decompile } -"Compiling a single quotation:" -{ $subsections compile-call } -"Higher-level words can be found in " { $link "compilation-units" } "." ; +"More words can be found in " { $link "compilation-units" } "." ; ARTICLE: "compiler-impl" "Compiler implementation" "The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop." @@ -72,8 +68,3 @@ HELP: compile-word HELP: optimizing-compiler { $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." } { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; - -HELP: compile-call -{ $values { "quot" quotation } } -{ $description "Compiles and runs a quotation." } -{ $notes "This word is used by compiler unit tests to test compilation of small pieces of code." } ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 2375d8575d..bf9b049127 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 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 @@ -181,14 +181,6 @@ t compile-dependencies? set-global : compile-loop ( deque -- ) [ compile-word yield-hook get call( -- ) ] slurp-deque ; -: decompile ( word -- ) - dup def>> 2array 1array modify-code-heap ; - -: compile-call ( quot -- ) - [ dup infer define-temp ] with-compilation-unit execute ; - -\ compile-call t "no-compile" set-word-prop - SINGLETON: optimizing-compiler M: optimizing-compiler recompile ( words -- alist ) @@ -220,6 +212,3 @@ M: optimizing-compiler process-forgotten-words : disable-optimizer ( -- ) f compiler-impl set-global ; - -: recompile-all ( -- ) - all-words compile ; diff --git a/basis/compiler/test/authors.txt b/basis/compiler/test/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/test/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/test/test.factor b/basis/compiler/test/test.factor new file mode 100644 index 0000000000..66e3f39f65 --- /dev/null +++ b/basis/compiler/test/test.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays compiler.units kernel stack-checker +sequences vocabs words tools.test tools.test.private ; +IN: compiler.test + +: decompile ( word -- ) + dup def>> 2array 1array modify-code-heap ; + +: recompile-all ( -- ) + all-words compile ; + +: compile-call ( quot -- ) + [ dup infer define-temp ] with-compilation-unit execute ; + +\ compile-call t "no-compile" set-word-prop + +: compiler-test ( name -- ) + "resource:basis/compiler/tests/" ".factor" surround run-test-file ; diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index cff685eaf6..288940e660 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -1,4 +1,4 @@ -USING: generalizations accessors arrays compiler kernel +USING: generalizations accessors arrays compiler.test kernel kernel.private math hashtables.private math.private namespaces sequences tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index b541e19f34..ddbd9ba646 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -1,5 +1,5 @@ USING: tools.test quotations math kernel sequences -assocs namespaces make compiler.units compiler ; +assocs namespaces make compiler.units compiler.test ; IN: compiler.tests.curry [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 632a560c0d..0d4e30279e 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -1,5 +1,6 @@ -USING: compiler.units compiler kernel kernel.private memory math -math.private tools.test math.floats.private math.order fry ; +USING: compiler.units compiler.test kernel kernel.private memory +math math.private tools.test math.floats.private math.order fry +; IN: compiler.tests.float [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 1c066f26a3..53017ff452 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -4,7 +4,7 @@ strings tools.test words continuations sequences.private hashtables.private byte-arrays system random layouts vectors sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.data alien.syntax alien.strings -namespaces libc io.encodings.ascii classes compiler ; +namespaces libc io.encodings.ascii classes compiler.test ; FROM: math => float ; IN: compiler.tests.intrinsics diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 865cd639a3..fe67cbbc37 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -4,7 +4,7 @@ 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 definitions generic.single shuffle math.order ; +compiler.test definitions generic.single shuffle math.order ; IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index a86d5b8c52..df67cadd78 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -1,4 +1,4 @@ -USING: compiler compiler.units tools.test kernel kernel.private +USING: compiler.test compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory vocabs parser eval quotations compiler.errors definitions ; diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index 3d6301249f..978c27768f 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -1,4 +1,4 @@ -USING: kernel tools.test compiler.units compiler ; +USING: kernel tools.test compiler.units compiler.test ; IN: compiler.tests.tuples TUPLE: color red green blue ; diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index 3c21b0cf3e..89aa1bd394 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -1,7 +1,7 @@ USING: kernel math math.floats.env math.floats.env.private math.functions math.libm sequences tools.test locals -compiler.units kernel.private fry compiler math.private words -system ; +compiler.units kernel.private fry compiler.test math.private +words system ; IN: math.floats.env.tests : set-default-fp-env ( -- ) diff --git a/basis/math/vectors/conversion/conversion-tests.factor b/basis/math/vectors/conversion/conversion-tests.factor index c91bdb369e..d46f062d9c 100644 --- a/basis/math/vectors/conversion/conversion-tests.factor +++ b/basis/math/vectors/conversion/conversion-tests.factor @@ -1,5 +1,5 @@ ! (c)Joe Groff bsd license -USING: accessors arrays compiler continuations generalizations +USING: accessors arrays compiler.test continuations generalizations kernel kernel.private locals math.vectors.conversion math.vectors.simd sequences stack-checker tools.test ; FROM: alien.c-types => char uchar short ushort int uint longlong ulonglong float double ; diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index 342c565dce..1d19c76dc1 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -1,4 +1,4 @@ -USING: accessors arrays classes compiler compiler.tree.debugger +USING: accessors arrays classes compiler.test compiler.tree.debugger effects fry io kernel kernel.private math math.functions math.private math.vectors math.vectors.simd math.vectors.simd.private prettyprint random sequences system diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index 8f3260d649..1a8ff824d6 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -1,6 +1,6 @@ USING: accessors tools.profiler tools.test kernel memory math threads alien alien.c-types tools.profiler.private sequences -compiler compiler.units words ; +compiler.test compiler.units words ; IN: tools.profiler.tests [ t ] [ diff --git a/basis/tools/time/time-tests.factor b/basis/tools/time/time-tests.factor index 00c774663c..3df61cbd36 100644 --- a/basis/tools/time/time-tests.factor +++ b/basis/tools/time/time-tests.factor @@ -1,4 +1,4 @@ IN: tools.time.tests -USING: tools.time tools.test compiler ; +USING: tools.time tools.test compiler.test ; [ ] [ [ [ ] time ] compile-call ] unit-test From ea5e168d77c25d254e57b8a3bd95d4eb62bcfd1c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Jan 2010 00:40:56 +1300 Subject: [PATCH 21/72] compiler.test: fix --- basis/compiler/test/test.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/test/test.factor b/basis/compiler/test/test.factor index 66e3f39f65..cc7b382253 100644 --- a/basis/compiler/test/test.factor +++ b/basis/compiler/test/test.factor @@ -13,7 +13,7 @@ IN: compiler.test : compile-call ( quot -- ) [ dup infer define-temp ] with-compilation-unit execute ; -\ compile-call t "no-compile" set-word-prop +<< \ compile-call t "no-compile" set-word-prop >> : compiler-test ( name -- ) "resource:basis/compiler/tests/" ".factor" surround run-test-file ; From 098ef42202d2eafb7adf6845dbcad029253c639a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Jan 2010 00:46:04 +1300 Subject: [PATCH 22/72] compiler: fix docs --- basis/compiler/compiler-docs.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 42d4edcc10..5ee0e265e4 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -56,10 +56,6 @@ $nl ABOUT: "compiler" -HELP: decompile -{ $values { "word" word } } -{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ; - HELP: compile-word { $values { "word" word } } { $description "Compile a single word." } From 790c7afeaf1b41d1d9a0635540f2aa5f823de082 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 Jan 2010 12:20:37 -0600 Subject: [PATCH 23/72] io.launcher: since process timeouts only kick in when wait-for-process is called, try-output-process would hang indefinitely. Fix this by splitting up wait-for-process and wrapping stream-contents in a with-timeout --- basis/io/launcher/launcher.factor | 23 ++++++++++---------- basis/io/launcher/windows/nt/nt-tests.factor | 14 ++++++++++++ 2 files changed, 26 insertions(+), 11 deletions(-) mode change 100644 => 100755 basis/io/launcher/launcher.factor mode change 100644 => 100755 basis/io/launcher/windows/nt/nt-tests.factor diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor old mode 100644 new mode 100755 index cb20f78a33..3999a026c0 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors @@ -127,16 +127,17 @@ M: process-was-killed error. "Launch descriptor:" print nl process>> . ; -: wait-for-process ( process -- status ) +: (wait-for-process) ( process -- status ) + dup handle>> [ - dup handle>> - [ - dup [ processes get at push ] curry - "process" suspend drop - ] when - dup killed>> - [ process-was-killed ] [ status>> ] if - ] with-timeout ; + dup [ processes get at push ] curry + "process" suspend drop + ] when + dup killed>> + [ process-was-killed ] [ status>> ] if ; + +: wait-for-process ( process -- status ) + [ (wait-for-process) ] with-timeout ; : run-detached ( desc -- process ) >process @@ -264,7 +265,7 @@ M: output-process-error error. +stdout+ >>stderr [ +closed+ or ] change-stdin utf8 - [ stream-contents ] [ dup wait-for-process ] bi* + [ [ stream-contents ] [ dup (wait-for-process) ] bi* ] with-timeout 0 = [ 2drop ] [ output-process-error ] if ; : notify-exit ( process status -- ) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor old mode 100644 new mode 100755 index 85999a89f7..c97c411d2c --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -23,6 +23,20 @@ IN: io.launcher.windows.nt.tests [ f ] [ "notepad" get process-running? ] unit-test +[ + + "notepad" >>command + 1/2 seconds >>timeout + try-process +] must-fail + +[ + + "notepad" >>command + 1/2 seconds >>timeout + try-output-process +] must-fail + : console-vm ( -- path ) vm ".exe" ?tail [ ".com" append ] when ; From bbd4e2727502f5a5f48ff570e629dbea0bed8368 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 19 Jan 2010 14:01:11 -0600 Subject: [PATCH 24/72] Tighten up libc file io code to avoid EINTR problems --- vm/image.cpp | 16 +++---- vm/io.cpp | 124 +++++++++++++++++++++++++++------------------------ vm/io.hpp | 4 ++ 3 files changed, 78 insertions(+), 66 deletions(-) diff --git a/vm/image.cpp b/vm/image.cpp index 68701c4736..54bd2f706d 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -22,7 +22,7 @@ void factor_vm::load_data_heap(FILE *file, image_header *h, vm_parameters *p) p->aging_size, p->tenured_size); - fixnum bytes_read = fread((void*)data->tenured->start,1,h->data_size,file); + fixnum bytes_read = safe_fread((void*)data->tenured->start,1,h->data_size,file); if((cell)bytes_read != h->data_size) { @@ -43,7 +43,7 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p) if(h->code_size != 0) { - size_t bytes_read = fread(code->allocator->first_block(),1,h->code_size,file); + size_t bytes_read = safe_fread(code->allocator->first_block(),1,h->code_size,file); if(bytes_read != h->code_size) { std::cout << "truncated image: " << bytes_read << " bytes read, "; @@ -241,7 +241,7 @@ void factor_vm::load_image(vm_parameters *p) } image_header h; - if(fread(&h,sizeof(image_header),1,file) != 1) + if(safe_fread(&h,sizeof(image_header),1,file) != 1) fatal_error("Cannot read image header",0); if(h.magic != image_magic) @@ -253,7 +253,7 @@ void factor_vm::load_image(vm_parameters *p) load_data_heap(file,&h,p); load_code_heap(file,&h,p); - fclose(file); + safe_fclose(file); init_objects(&h); @@ -298,10 +298,10 @@ bool factor_vm::save_image(const vm_char *filename) bool ok = true; - if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false; - if(fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false; - if(fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false; - if(fclose(file)) ok = false; + if(safe_fwrite(&h,sizeof(image_header),1,file) != 1) ok = false; + if(safe_fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false; + if(safe_fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false; + if(safe_fclose(file)) ok = false; if(!ok) std::cout << "save-image failed: " << strerror(errno) << std::endl; diff --git a/vm/io.cpp b/vm/io.cpp index a45e1d10ab..9722676f31 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -31,6 +31,39 @@ void factor_vm::io_error() general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL); } +size_t safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream) +{ + size_t items_read = 0; + + do { + items_read += fread((void*)((int*)ptr+items_read*size),size,nitems-items_read,stream); + } while(items_read != nitems && errno == EINTR); + + return items_read; +} + +size_t safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream) +{ + size_t items_written = 0; + + do { + items_written += fwrite((void*)((int*)ptr+items_written*size),size,nitems-items_written,stream); + } while(items_written != nitems && errno == EINTR); + + return items_written; +} + +int safe_fclose(FILE *stream) +{ + int ret = 0; + + do { + ret = fclose(stream); + } while(ret != 0 && errno == EINTR); + + return ret; +} + void factor_vm::primitive_fopen() { data_root mode(ctx->pop(),this); @@ -38,18 +71,15 @@ void factor_vm::primitive_fopen() mode.untag_check(this); path.untag_check(this); - for(;;) - { - FILE *file = fopen((char *)(path.untagged() + 1), + FILE *file; + do { + file = fopen((char *)(path.untagged() + 1), (char *)(mode.untagged() + 1)); if(file == NULL) io_error(); - else - { - ctx->push(allot_alien(file)); - break; - } - } + } while(errno == EINTR); + + ctx->push(allot_alien(file)); } FILE *factor_vm::pop_file_handle() @@ -61,8 +91,7 @@ void factor_vm::primitive_fgetc() { FILE *file = pop_file_handle(); - for(;;) - { + do { int c = fgetc(file); if(c == EOF) { @@ -79,7 +108,7 @@ void factor_vm::primitive_fgetc() ctx->push(tag_fixnum(c)); break; } - } + } while(errno == EINTR); } void factor_vm::primitive_fread() @@ -97,8 +126,8 @@ void factor_vm::primitive_fread() for(;;) { - int c = fread(buf.untagged() + 1,1,size,file); - if(c <= 0) + int c = safe_fread(buf.untagged() + 1,1,size,file); + if(c == 0) { if(feof(file)) { @@ -110,12 +139,13 @@ void factor_vm::primitive_fread() } else { - if(c != size) + if(feof(file)) { byte_array *new_buf = allot_byte_array(c); memcpy(new_buf + 1, buf.untagged() + 1,c); buf = new_buf; } + ctx->push(buf.value()); break; } @@ -127,17 +157,12 @@ void factor_vm::primitive_fputc() FILE *file = pop_file_handle(); fixnum ch = to_fixnum(ctx->pop()); - for(;;) - { + do { if(fputc(ch,file) == EOF) - { io_error(); - - /* Still here? EINTR */ - } else break; - } + } while(errno == EINTR); } void factor_vm::primitive_fwrite() @@ -150,23 +175,9 @@ void factor_vm::primitive_fwrite() if(length == 0) return; - for(;;) - { - size_t written = fwrite(string,1,length,file); - if(written == length) - break; - else - { - if(feof(file)) - break; - else - io_error(); - - /* Still here? EINTR */ - length -= written; - string += written; - } - } + size_t written = safe_fwrite(string,1,length,file); + if(written != length) + io_error(); } void factor_vm::primitive_ftell() @@ -174,8 +185,12 @@ void factor_vm::primitive_ftell() FILE *file = pop_file_handle(); off_t offset; - if((offset = FTELL(file)) == -1) - io_error(); + do { + if((offset = FTELL(file)) == -1) + io_error(); + else + break; + } while(errno == EINTR); ctx->push(from_signed_8(offset)); } @@ -196,37 +211,30 @@ void factor_vm::primitive_fseek() break; } - if(FSEEK(file,offset,whence) == -1) - { - io_error(); - - /* Still here? EINTR */ - critical_error("Don't know what to do; EINTR from fseek()?",0); - } + do { + if(FSEEK(file,offset,whence) == -1) + io_error(); + else + break; + } while(errno == EINTR); } void factor_vm::primitive_fflush() { FILE *file = pop_file_handle(); - for(;;) - { + do { if(fflush(file) == EOF) io_error(); else break; - } + } while(errno == EINTR); } void factor_vm::primitive_fclose() { FILE *file = pop_file_handle(); - for(;;) - { - if(fclose(file) == EOF) - io_error(); - else - break; - } + if(safe_fclose(file) == EOF) + io_error(); } /* This function is used by FFI I/O. Accessing the errno global directly is diff --git a/vm/io.hpp b/vm/io.hpp index 7fa43e0006..41e9cec82d 100755 --- a/vm/io.hpp +++ b/vm/io.hpp @@ -1,6 +1,10 @@ namespace factor { +size_t safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream); +size_t safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream); +int safe_fclose(FILE *stream); + /* Platform specific primitives */ VM_C_API int err_no(); From 07fcb43a062c3b44817f74e3cf6df994b40a9aa7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 19 Jan 2010 16:53:15 -0600 Subject: [PATCH 25/72] Make unix-system-call retry the call immediately upon hitting EINTR. Use unix-system-call wherever EAGAIN or EINPROGRESS are not handled. Handle EINTR if connect returns it. --- basis/io/backend/unix/unix.factor | 8 ++--- basis/io/directories/unix/linux/linux.factor | 2 +- basis/io/directories/unix/unix.factor | 12 ++++---- basis/io/files/info/unix/unix.factor | 9 +++--- basis/io/files/links/unix/unix.factor | 4 +-- basis/io/files/unix/unix.factor | 5 +-- basis/io/sockets/unix/unix.factor | 18 ++++++++--- basis/unix/unix.factor | 32 +++++++++++++++----- 8 files changed, 59 insertions(+), 31 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index a8070525c7..2ab5bdca05 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -17,8 +17,8 @@ TUPLE: fd < disposable fd ; : init-fd ( fd -- fd ) [ |dispose - dup fd>> F_SETFL O_NONBLOCK fcntl io-error - dup fd>> F_SETFD FD_CLOEXEC fcntl io-error + dup fd>> F_SETFL O_NONBLOCK [ fcntl ] unix-system-call io-error + dup fd>> F_SETFD FD_CLOEXEC [ fcntl ] unix-system-call io-error ] with-destructors ; : ( n -- fd ) @@ -50,7 +50,7 @@ M: fd cancel-operation ( fd -- ) ] if ; M: unix tell-handle ( handle -- n ) - fd>> 0 SEEK_CUR lseek [ io-error ] [ ] bi ; + fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ; M: unix seek-handle ( n seek-type handle -- ) swap { @@ -59,7 +59,7 @@ M: unix seek-handle ( n seek-type handle -- ) { io:seek-end [ SEEK_END ] } [ io:bad-seek-type ] } case - [ fd>> swap ] dip lseek io-error ; + [ fd>> swap ] dip [ lseek ] unix-system-call io-error ; SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor index 3af4c09f28..c5678fae9c 100644 --- a/basis/io/directories/unix/linux/linux.factor +++ b/basis/io/directories/unix/linux/linux.factor @@ -7,5 +7,5 @@ IN: io.directories.unix.linux M: unix find-next-file ( DIR* -- dirent ) dirent f - [ readdir64_r 0 = [ (io-error) ] unless ] 2keep + [ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep *void* [ drop f ] unless ; diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 06ba73bb46..b1f6596759 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -17,29 +17,29 @@ M: unix touch-file ( path -- ) ] if ; M: unix move-file ( from to -- ) - [ normalize-path ] bi@ rename io-error ; + [ normalize-path ] bi@ [ rename ] unix-system-call io-error ; M: unix delete-file ( path -- ) normalize-path unlink-file ; M: unix make-directory ( path -- ) - normalize-path OCT: 777 mkdir io-error ; + normalize-path OCT: 777 [ mkdir ] unix-system-call io-error ; M: unix delete-directory ( path -- ) - normalize-path rmdir io-error ; + normalize-path [ rmdir ] unix-system-call io-error ; M: unix copy-file ( from to -- ) [ normalize-path ] bi@ call-next-method ; : with-unix-directory ( path quot -- ) - [ opendir dup [ (io-error) ] unless ] dip - dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline + [ [ opendir ] unix-system-call dup [ (io-error) ] unless ] dip + dupd curry swap '[ _ [ closedir ] unix-system-call io-error ] [ ] cleanup ; inline HOOK: find-next-file os ( DIR* -- byte-array ) M: unix find-next-file ( DIR* -- byte-array ) dirent f - [ readdir_r 0 = [ (io-error) ] unless ] 2keep + [ [ readdir_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep *void* [ drop f ] unless ; : dirent-type>file-type ( ch -- type ) diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index eedf8de47a..180f194c89 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -109,7 +109,7 @@ M: unix stat>type ( stat -- type ) : chmod-set-bit ( path mask ? -- ) [ dup stat-mode ] 2dip - [ bitor ] [ unmask ] if chmod io-error ; + [ bitor ] [ unmask ] if [ chmod ] unix-system-call io-error ; GENERIC# file-mode? 1 ( obj mask -- ? ) @@ -174,7 +174,7 @@ CONSTANT: ALL-EXECUTE OCT: 0000111 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ; : set-file-permissions ( path n -- ) - [ normalize-path ] dip chmod io-error ; + [ normalize-path ] dip [ chmod ] unix-system-call io-error ; : file-permissions ( path -- n ) normalize-path file-info permissions>> ; @@ -202,7 +202,7 @@ PRIVATE> : set-file-times ( path timestamps -- ) #! set access, write [ normalize-path ] dip - timestamps>byte-array utimes io-error ; + timestamps>byte-array [ utimes ] unix-system-call io-error ; : set-file-access-time ( path timestamp -- ) f 2array set-file-times ; @@ -211,7 +211,8 @@ PRIVATE> f swap 2array set-file-times ; : set-file-ids ( path uid gid -- ) - [ normalize-path ] 2dip [ -1 or ] bi@ chown io-error ; + [ normalize-path ] 2dip [ -1 or ] bi@ + [ chown ] unix-system-call io-error ; GENERIC: set-file-user ( path string/id -- ) diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index f41adfa731..ced4c11c59 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -5,10 +5,10 @@ io.files sequences ; IN: io.files.links.unix M: unix make-link ( path1 path2 -- ) - normalize-path symlink io-error ; + normalize-path [ symlink ] unix-system-call io-error ; M: unix make-hard-link ( path1 path2 -- ) - normalize-path link io-error ; + normalize-path [ link ] unix-system-call io-error ; M: unix read-link ( path -- path' ) normalize-path read-symbolic-link ; diff --git a/basis/io/files/unix/unix.factor b/basis/io/files/unix/unix.factor index 9518d1c754..783e40a70c 100644 --- a/basis/io/files/unix/unix.factor +++ b/basis/io/files/unix/unix.factor @@ -6,7 +6,8 @@ destructors system ; IN: io.files.unix M: unix cwd ( -- path ) - MAXPATHLEN [ ] keep getcwd + MAXPATHLEN [ ] keep + [ getcwd ] unix-system-call [ (io-error) ] unless* ; M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; @@ -33,7 +34,7 @@ M: unix (file-writer) ( path -- stream ) : open-append ( path -- fd ) [ append-flags file-mode open-file |dispose - dup 0 SEEK_END lseek io-error + dup 0 SEEK_END [ lseek ] unix-system-call io-error ] with-destructors ; M: unix (file-appender) ( path -- stream ) diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index cdf7e54408..4f25435985 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -59,10 +59,15 @@ M: object (get-remote-address) ( handle local -- sockaddr ) [ (io-error) ] } cond ; -M: object establish-connection ( client-out remote -- ) - [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi +M:: object establish-connection ( client-out remote -- ) + client-out remote + [ drop ] + [ + [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect + ] 2bi { { [ 0 = ] [ drop ] } + { [ errno EINTR = ] [ drop client-out remote establish-connection ] } { [ errno EINPROGRESS = ] [ [ +output+ wait-for-port ] [ wait-to-connect ] bi ] } @@ -70,7 +75,12 @@ M: object establish-connection ( client-out remote -- ) } cond ; : ?bind-client ( socket -- ) - bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline + bind-local-address get [ + [ fd>> ] dip make-sockaddr/size + [ bind ] unix-system-call io-error + ] [ + drop + ] if* ; inline M: object ((client)) ( addrspec -- fd ) protocol-family SOCK_STREAM socket-fd @@ -83,7 +93,7 @@ M: object ((client)) ( addrspec -- fd ) : server-socket-fd ( addrspec type -- fd ) [ dup protocol-family ] dip socket-fd [ init-server-socket ] keep - [ handle-fd swap make-sockaddr/size bind io-error ] keep ; + [ handle-fd swap make-sockaddr/size [ bind ] unix-system-call io-error ] keep ; M: object (server) ( addrspec -- handle ) [ diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index e9cb9d5918..86b8646bdd 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2005, 2010 Slava Pestov. ! Copyright (C) 2008 Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax kernel libc sequences -continuations byte-arrays strings math namespaces system -combinators combinators.smart vocabs.loader accessors -stack-checker macros locals generalizations unix.types io vocabs -classes.struct unix.time alien.libraries ; +USING: accessors alien alien.c-types alien.libraries +alien.syntax byte-arrays classes.struct combinators +combinators.short-circuit combinators.smart continuations +generalizations io kernel libc locals macros math namespaces +sequences stack-checker strings system unix.time unix.types +vocabs vocabs.loader ; IN: unix CONSTANT: PROT_NONE 0 @@ -47,17 +48,32 @@ ERROR: unix-error errno message ; ERROR: unix-system-call-error args errno message word ; +: unix-call-failed? ( ret -- ? ) + { + [ { [ integer? ] [ 0 < ] } 1&& ] + [ not ] + } 1|| ; + MACRO:: unix-system-call ( quot -- ) quot inputs :> n quot first :> word + 0 :> ret! + f :> failed! [ - n ndup quot call dup 0 < [ - drop + [ + n ndup quot call ret! + ret { + [ unix-call-failed? dup failed! ] + [ drop errno EINTR = ] + } 1&& + ] loop + failed [ n narray errno dup strerror word unix-system-call-error ] [ - n nnip + n ndrop + ret ] if ] ; From bb2f4557479d3af7c7548fc9b2f2be8f7219f4bb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 Jan 2010 22:40:25 -0600 Subject: [PATCH 26/72] Save images to a temporary file first, then call MOVE_FILE to avoid writing incomplete and truncated images. --- .../known-words/known-words.factor | 4 ++-- core/bootstrap/primitives.factor | 4 ++-- core/memory/memory.factor | 12 +++++++---- vm/debug.cpp | 2 +- vm/image.cpp | 21 ++++++++++++------- vm/os-unix.hpp | 9 ++++++++ vm/os-windows.hpp | 9 ++++++-- vm/vm.hpp | 2 +- 8 files changed, 43 insertions(+), 20 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 9bc61c6353..6ac668b031 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -516,9 +516,9 @@ M: bad-executable summary \ compact-gc { } { } define-primitive -\ (save-image) { byte-array } { } define-primitive +\ (save-image) { byte-array byte-array } { } define-primitive -\ (save-image-and-exit) { byte-array } { } define-primitive +\ (save-image-and-exit) { byte-array byte-array } { } define-primitive \ data-room { } { byte-array } define-primitive \ data-room make-flushable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index dde5463c0f..2288b89cf4 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -511,8 +511,8 @@ tuple { "gc" "memory" "primitive_full_gc" (( -- )) } { "minor-gc" "memory" "primitive_minor_gc" (( -- )) } { "size" "memory" "primitive_size" (( obj -- n )) } - { "(save-image)" "memory.private" "primitive_save_image" (( path -- )) } - { "(save-image-and-exit)" "memory.private" "primitive_save_image_and_exit" (( path -- )) } + { "(save-image)" "memory.private" "primitive_save_image" (( path1 path2 -- )) } + { "(save-image-and-exit)" "memory.private" "primitive_save_image_and_exit" (( path1 path2 -- )) } { "jit-compile" "quotations" "primitive_jit_compile" (( quot -- )) } { "quot-compiled?" "quotations" "primitive_quot_compiled_p" (( quot -- ? )) } { "quotation-code" "quotations" "primitive_quotation_code" (( quot -- start end )) } diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 4ab68a1ef1..0fba4dee77 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,16 +1,20 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences system -io.backend alien.strings memory.private ; +USING: alien.strings io.backend io.pathnames kernel +memory.private sequences system ; IN: memory : instances ( quot -- seq ) [ all-instances ] dip filter ; inline +: saving-path ( path -- saving-path path ) + [ ".saving" append-path ] keep + [ native-string>alien ] bi@ ; + : save-image ( path -- ) - normalize-path native-string>alien (save-image) ; + normalize-path saving-path (save-image) ; : save-image-and-exit ( path -- ) - normalize-path native-string>alien (save-image-and-exit) ; + normalize-path saving-path (save-image-and-exit) ; : save ( -- ) image save-image ; diff --git a/vm/debug.cpp b/vm/debug.cpp index 419eb690ff..e82394951a 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -442,7 +442,7 @@ void factor_vm::factorbug() else if(strcmp(cmd,"x") == 0) exit(1); else if(strcmp(cmd,"im") == 0) - save_image(STRING_LITERAL("fep.image")); + save_image(STRING_LITERAL("fep.image.saving"),STRING_LITERAL("fep.image")); else if(strcmp(cmd,"data") == 0) dump_objects(TYPE_COUNT); else if(strcmp(cmd,"refs") == 0) diff --git a/vm/image.cpp b/vm/image.cpp index 54bd2f706d..bfc9f3daca 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -268,12 +268,12 @@ void factor_vm::load_image(vm_parameters *p) } /* Save the current image to disk */ -bool factor_vm::save_image(const vm_char *filename) +bool factor_vm::save_image(const vm_char *saving_filename, const vm_char *filename) { FILE* file; image_header h; - file = OPEN_WRITE(filename); + file = OPEN_WRITE(saving_filename); if(file == NULL) { std::cout << "Cannot open image file: " << filename << std::endl; @@ -303,6 +303,7 @@ bool factor_vm::save_image(const vm_char *filename) if(safe_fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false; if(safe_fclose(file)) ok = false; + MOVE_FILE(saving_filename,filename); if(!ok) std::cout << "save-image failed: " << strerror(errno) << std::endl; @@ -314,9 +315,11 @@ void factor_vm::primitive_save_image() /* do a full GC to push everything into tenured space */ primitive_compact_gc(); - data_root path(ctx->pop(),this); - path.untag_check(this); - save_image((vm_char *)(path.untagged() + 1)); + data_root path1(ctx->pop(),this); + path1.untag_check(this); + data_root path2(ctx->pop(),this); + path2.untag_check(this); + save_image((vm_char *)(path1.untagged() + 1 ),(vm_char *)(path2.untagged() + 1)); } void factor_vm::primitive_save_image_and_exit() @@ -324,8 +327,10 @@ void factor_vm::primitive_save_image_and_exit() /* We unbox this before doing anything else. This is the only point where we might throw an error, so we have to throw an error here since later steps destroy the current image. */ - data_root path(ctx->pop(),this); - path.untag_check(this); + data_root path1(ctx->pop(),this); + path1.untag_check(this); + data_root path2(ctx->pop(),this); + path2.untag_check(this); /* strip out special_objects data which is set on startup anyway */ for(cell i = 0; i < special_object_count; i++) @@ -336,7 +341,7 @@ void factor_vm::primitive_save_image_and_exit() false /* discard objects only reachable from stacks */); /* Save the image */ - if(save_image((vm_char *)(path.untagged() + 1))) + if(save_image((vm_char *)(path1.untagged() + 1), (vm_char *)(path2.untagged() + 1))) exit(0); else exit(1); diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 7faab4d8b8..5efa62919d 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -31,6 +31,15 @@ typedef char symbol_char; #define OPEN_READ(path) fopen(path,"rb") #define OPEN_WRITE(path) fopen(path,"wb") +#define MOVE_FILE(path1,path2) \ +do {\ + int ret = 0;\ + do {\ + ret = rename((path1),(path2));\ + } while(ret < 0 && errno == EINTR);\ + if(ret < 0)\ + general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);\ +}while(0) #define print_native_string(string) print_string(string) diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 8a2dfe38f5..0569d85b61 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -37,8 +37,13 @@ typedef wchar_t vm_char; #define CELL_HEX_FORMAT "%lx" #endif -#define OPEN_READ(path) _wfopen(path,L"rb") -#define OPEN_WRITE(path) _wfopen(path,L"wb") +#define OPEN_READ(path) _wfopen((path),L"rb") +#define OPEN_WRITE(path) _wfopen((path),L"wb") +#define MOVE_FILE(path1,path2) \ +do {\ + if(MoveFile((path1),(path2)) == 0)\ + general_error(ERROR_IO,tag_fixnum(GetLastError()),false_object,NULL);\ +} while(0) /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ #define EPOCH_OFFSET 0x019db1ded53e8000LL diff --git a/vm/vm.hpp b/vm/vm.hpp index 6f826ed9e0..6fb788d531 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -549,7 +549,7 @@ struct factor_vm void init_objects(image_header *h); void load_data_heap(FILE *file, image_header *h, vm_parameters *p); void load_code_heap(FILE *file, image_header *h, vm_parameters *p); - bool save_image(const vm_char *filename); + bool save_image(const vm_char *saving_filename, const vm_char *filename); void primitive_save_image(); void primitive_save_image_and_exit(); void fixup_data(cell data_offset, cell code_offset); From 8d952277a244669b762d3e5b90f1c55b7daf641c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 Jan 2010 22:42:07 -0600 Subject: [PATCH 27/72] Handle EINTR in a lot of cases where it wasn't handled before. Split off unix into unix.ffi and unix. --- basis/environment/unix/unix.factor | 2 +- basis/io/backend/unix/unix.factor | 2 +- basis/io/directories/unix/unix.factor | 2 +- basis/io/files/info/info.factor | 2 +- basis/io/files/info/unix/unix.factor | 16 +- basis/io/files/links/unix/unix.factor | 4 +- basis/io/files/unix/unix.factor | 2 +- basis/io/launcher/unix/unix.factor | 2 +- basis/io/pipes/unix/unix.factor | 2 +- basis/io/sockets/secure/unix/unix.factor | 3 +- basis/io/sockets/sockets.factor | 2 +- basis/io/sockets/unix/unix.factor | 2 +- basis/unix/debugger/debugger.factor | 5 +- basis/unix/ffi/authors.txt | 1 + basis/unix/{ => ffi}/bsd/authors.txt | 0 basis/unix/{ => ffi}/bsd/bsd.factor | 10 +- .../unix/{ => ffi}/bsd/freebsd/freebsd.factor | 2 +- basis/unix/{ => ffi}/bsd/freebsd/tags.txt | 0 basis/unix/{ => ffi}/bsd/macosx/macosx.factor | 7 +- basis/unix/{ => ffi}/bsd/macosx/tags.txt | 0 basis/unix/{ => ffi}/bsd/netbsd/netbsd.factor | 4 +- .../bsd/netbsd/structs/structs.factor | 0 .../{ => ffi}/bsd/netbsd/structs/tags.txt | 0 basis/unix/{ => ffi}/bsd/netbsd/tags.txt | 0 .../unix/{ => ffi}/bsd/openbsd/openbsd.factor | 2 +- basis/unix/{ => ffi}/bsd/openbsd/tags.txt | 0 basis/unix/{ => ffi}/bsd/summary.txt | 0 basis/unix/{ => ffi}/bsd/tags.txt | 0 basis/unix/ffi/ffi.factor | 158 ++++++++++++ basis/unix/ffi/linux/authors.txt | 1 + basis/unix/ffi/linux/linux.factor | 236 +++++++++++++++++ basis/unix/{ => ffi}/solaris/authors.txt | 0 basis/unix/{ => ffi}/solaris/solaris.factor | 4 +- basis/unix/{debugger => ffi/solaris}/tags.txt | 0 basis/unix/groups/groups.factor | 28 +- basis/unix/linux/linux.factor | 239 +----------------- basis/unix/solaris/tags.txt | 1 - basis/unix/stat/macosx/macosx.factor | 2 +- basis/unix/statfs/macosx/macosx.factor | 2 +- basis/unix/unix.factor | 170 +------------ basis/unix/users/users.factor | 20 +- 41 files changed, 471 insertions(+), 462 deletions(-) create mode 100644 basis/unix/ffi/authors.txt rename basis/unix/{ => ffi}/bsd/authors.txt (100%) rename basis/unix/{ => ffi}/bsd/bsd.factor (89%) rename basis/unix/{ => ffi}/bsd/freebsd/freebsd.factor (99%) rename basis/unix/{ => ffi}/bsd/freebsd/tags.txt (100%) rename basis/unix/{ => ffi}/bsd/macosx/macosx.factor (95%) rename basis/unix/{ => ffi}/bsd/macosx/tags.txt (100%) rename basis/unix/{ => ffi}/bsd/netbsd/netbsd.factor (98%) rename basis/unix/{ => ffi}/bsd/netbsd/structs/structs.factor (100%) rename basis/unix/{ => ffi}/bsd/netbsd/structs/tags.txt (100%) rename basis/unix/{ => ffi}/bsd/netbsd/tags.txt (100%) rename basis/unix/{ => ffi}/bsd/openbsd/openbsd.factor (99%) rename basis/unix/{ => ffi}/bsd/openbsd/tags.txt (100%) rename basis/unix/{ => ffi}/bsd/summary.txt (100%) rename basis/unix/{ => ffi}/bsd/tags.txt (100%) create mode 100644 basis/unix/ffi/ffi.factor create mode 100644 basis/unix/ffi/linux/authors.txt create mode 100644 basis/unix/ffi/linux/linux.factor rename basis/unix/{ => ffi}/solaris/authors.txt (100%) rename basis/unix/{ => ffi}/solaris/solaris.factor (97%) rename basis/unix/{debugger => ffi/solaris}/tags.txt (100%) delete mode 100644 basis/unix/solaris/tags.txt diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor index 3fc8c2f79b..ec41e919d8 100644 --- a/basis/environment/unix/unix.factor +++ b/basis/environment/unix/unix.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.data alien.strings alien.syntax kernel layouts sequences system unix environment io.encodings.utf8 unix.utilities vocabs.loader -combinators alien.accessors ; +combinators alien.accessors unix.ffi ; IN: environment.unix HOOK: environ os ( -- void* ) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 2ab5bdca05..6412132725 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax generic assocs kernel kernel.private math io.ports sequences strings sbufs threads -unix vectors io.buffers io.backend io.encodings math.parser +unix unix.ffi vectors io.buffers io.backend io.encodings math.parser continuations system libc namespaces make io.timeouts io.encodings.utf8 destructors destructors.private accessors summary combinators locals unix.time unix.types fry diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index b1f6596759..a62a431de8 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators continuations destructors fry io io.backend io.backend.unix io.directories io.encodings.binary io.encodings.utf8 io.files io.pathnames io.files.types kernel math.bitwise sequences system -unix unix.stat vocabs.loader classes.struct ; +unix unix.stat vocabs.loader classes.struct unix.ffi ; IN: io.directories.unix : touch-mode ( -- n ) diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index 60a9308f38..500fd62cd3 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -26,7 +26,7 @@ available-space free-space used-space total-space ; HOOK: file-system-info os ( path -- file-system-info ) { - { [ os unix? ] [ "io.files.info.unix." os name>> append ] } + { [ os unix? ] [ "io.files.info" ] } { [ os windows? ] [ "io.files.info.windows" ] } } cond require diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 180f194c89..ff604759c1 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel system math math.bitwise strings arrays -sequences combinators combinators.short-circuit alien.c-types -vocabs.loader calendar calendar.unix io.files.info -io.files.types io.backend io.directories unix unix.stat -unix.time unix.users unix.groups classes.struct -specialized-arrays literals ; -SPECIALIZED-ARRAY: timeval +USING: accessors alien.c-types arrays calendar calendar.unix +classes.struct combinators combinators.short-circuit io.backend +io.directories io.files.info io.files.types kernel literals +math math.bitwise sequences specialized-arrays strings system +unix unix.ffi unix.groups unix.stat unix.time unix.users +vocabs.loader ; IN: io.files.info.unix +SPECIALIZED-ARRAY: timeval TUPLE: unix-file-system-info < file-system-info block-size preferred-block-size @@ -286,3 +286,5 @@ PRIVATE> { +regular-file+ [ file-type>executable ] } [ drop file-type>executable ] } case ; + +"io.files.info.unix." os name>> append require diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index ced4c11c59..f97478c332 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.files.links system unix io.pathnames kernel -io.files sequences ; +USING: io.backend io.files io.files.links io.pathnames kernel +sequences system unix unix.ffi ; IN: io.files.links.unix M: unix make-link ( path1 path2 -- ) diff --git a/basis/io/files/unix/unix.factor b/basis/io/files/unix/unix.factor index 783e40a70c..7293cf67fa 100644 --- a/basis/io/files/unix/unix.factor +++ b/basis/io/files/unix/unix.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: unix byte-arrays kernel io.backend.unix math.bitwise io.ports io.files io.files.private io.pathnames environment -destructors system ; +destructors system unix.ffi ; IN: io.files.unix M: unix cwd ( -- path ) diff --git a/basis/io/launcher/unix/unix.factor b/basis/io/launcher/unix/unix.factor index a9e3324986..28c805a528 100644 --- a/basis/io/launcher/unix/unix.factor +++ b/basis/io/launcher/unix/unix.factor @@ -5,7 +5,7 @@ continuations environment io io.backend io.backend.unix io.files io.files.private io.files.unix io.launcher io.launcher.unix.parser io.pathnames io.ports kernel math namespaces sequences strings system threads unix -unix.process ; +unix.process unix.ffi ; IN: io.launcher.unix : get-arguments ( process -- seq ) diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor index 8493f14d26..7dbeb0a589 100644 --- a/basis/io/pipes/unix/unix.factor +++ b/basis/io/pipes/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types system kernel unix math sequences -io.backend.unix io.ports specialized-arrays accessors ; +io.backend.unix io.ports specialized-arrays accessors unix.ffi ; QUALIFIED: io.pipes SPECIALIZED-ARRAY: int IN: io.pipes.unix diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index b04d282530..8fe9facc0c 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -6,7 +6,8 @@ alien.strings libc continuations destructors openssl openssl.libcrypto openssl.libssl io io.files io.ports io.backend.unix io.sockets.unix io.encodings.ascii io.buffers io.sockets io.sockets.private io.sockets.secure -io.sockets.secure.openssl io.timeouts system summary fry ; +io.sockets.secure.openssl io.timeouts system summary fry +unix.ffi ; FROM: io.ports => shutdown ; IN: io.sockets.secure.unix diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index e45224fcc2..af21dac9b7 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -11,7 +11,7 @@ IN: io.sockets << { { [ os windows? ] [ "windows.winsock" ] } - { [ os unix? ] [ "unix" ] } + { [ os unix? ] [ "unix.ffi" ] } } cond use-vocab >> ! Addressing diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index 4f25435985..fcf84f7925 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -5,7 +5,7 @@ threads sequences byte-arrays io.binary io.backend.unix io.streams.duplex io.backend io.pathnames io.sockets.private io.files.private io.encodings.utf8 math.parser continuations libc combinators system accessors destructors unix locals init -classes.struct alien.data ; +classes.struct alien.data unix.ffi ; EXCLUDE: namespaces => bind ; EXCLUDE: io => read write ; diff --git a/basis/unix/debugger/debugger.factor b/basis/unix/debugger/debugger.factor index 4e276373e1..7a085731d1 100644 --- a/basis/unix/debugger/debugger.factor +++ b/basis/unix/debugger/debugger.factor @@ -1,7 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger prettyprint accessors unix kernel ; -FROM: io => write print nl ; +USING: accessors debugger io kernel prettyprint unix ; IN: unix.debugger M: unix-error error. diff --git a/basis/unix/ffi/authors.txt b/basis/unix/ffi/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/ffi/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/bsd/authors.txt b/basis/unix/ffi/bsd/authors.txt similarity index 100% rename from basis/unix/bsd/authors.txt rename to basis/unix/ffi/bsd/authors.txt diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/ffi/bsd/bsd.factor similarity index 89% rename from basis/unix/bsd/bsd.factor rename to basis/unix/ffi/bsd/bsd.factor index 0825e42930..bda99422fc 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/ffi/bsd/bsd.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax classes.struct combinators system unix.types vocabs.loader ; -IN: unix +IN: unix.ffi CONSTANT: MAXPATHLEN 1024 @@ -85,8 +85,8 @@ CONSTANT: SEEK_CUR 1 CONSTANT: SEEK_END 2 os { - { macosx [ "unix.bsd.macosx" require ] } - { freebsd [ "unix.bsd.freebsd" require ] } - { openbsd [ "unix.bsd.openbsd" require ] } - { netbsd [ "unix.bsd.netbsd" require ] } + { macosx [ "unix.ffi.bsd.macosx" require ] } + { freebsd [ "unix.ffi.bsd.freebsd" require ] } + { openbsd [ "unix.ffi.bsd.openbsd" require ] } + { netbsd [ "unix.ffi.bsd.netbsd" require ] } } case diff --git a/basis/unix/bsd/freebsd/freebsd.factor b/basis/unix/ffi/bsd/freebsd/freebsd.factor similarity index 99% rename from basis/unix/bsd/freebsd/freebsd.factor rename to basis/unix/ffi/bsd/freebsd/freebsd.factor index e6a2070520..992d1c3ad0 100644 --- a/basis/unix/bsd/freebsd/freebsd.factor +++ b/basis/unix/ffi/bsd/freebsd/freebsd.factor @@ -1,5 +1,5 @@ USING: alien.c-types alien.syntax classes.struct unix.types ; -IN: unix +IN: unix.ffi CONSTANT: FD_SETSIZE 1024 diff --git a/basis/unix/bsd/freebsd/tags.txt b/basis/unix/ffi/bsd/freebsd/tags.txt similarity index 100% rename from basis/unix/bsd/freebsd/tags.txt rename to basis/unix/ffi/bsd/freebsd/tags.txt diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/ffi/bsd/macosx/macosx.factor similarity index 95% rename from basis/unix/bsd/macosx/macosx.factor rename to basis/unix/ffi/bsd/macosx/macosx.factor index c263be7056..a2e75b6ca6 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/ffi/bsd/macosx/macosx.factor @@ -1,6 +1,7 @@ -USING: alien.c-types alien.syntax unix.time unix.types -unix.types.macosx classes.struct ; -IN: unix +USING: alien alien.c-types alien.libraries alien.syntax +classes.struct combinators kernel system unix unix.time +unix.types vocabs vocabs.loader ; +IN: unix.ffi CONSTANT: FD_SETSIZE 1024 diff --git a/basis/unix/bsd/macosx/tags.txt b/basis/unix/ffi/bsd/macosx/tags.txt similarity index 100% rename from basis/unix/bsd/macosx/tags.txt rename to basis/unix/ffi/bsd/macosx/tags.txt diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/ffi/bsd/netbsd/netbsd.factor similarity index 98% rename from basis/unix/bsd/netbsd/netbsd.factor rename to basis/unix/ffi/bsd/netbsd/netbsd.factor index 6bef08abe3..0aee585b48 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/ffi/bsd/netbsd/netbsd.factor @@ -1,6 +1,6 @@ USING: alien.syntax alien.c-types math vocabs.loader classes.struct unix.types ; -IN: unix +IN: unix.ffi CONSTANT: FD_SETSIZE 256 @@ -138,4 +138,4 @@ CONSTANT: _SS_MAXSIZE 128 : _SS_PAD2SIZE ( -- n ) _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline -"unix.bsd.netbsd.structs" require +"unix.ffi.bsd.netbsd.structs" require diff --git a/basis/unix/bsd/netbsd/structs/structs.factor b/basis/unix/ffi/bsd/netbsd/structs/structs.factor similarity index 100% rename from basis/unix/bsd/netbsd/structs/structs.factor rename to basis/unix/ffi/bsd/netbsd/structs/structs.factor diff --git a/basis/unix/bsd/netbsd/structs/tags.txt b/basis/unix/ffi/bsd/netbsd/structs/tags.txt similarity index 100% rename from basis/unix/bsd/netbsd/structs/tags.txt rename to basis/unix/ffi/bsd/netbsd/structs/tags.txt diff --git a/basis/unix/bsd/netbsd/tags.txt b/basis/unix/ffi/bsd/netbsd/tags.txt similarity index 100% rename from basis/unix/bsd/netbsd/tags.txt rename to basis/unix/ffi/bsd/netbsd/tags.txt diff --git a/basis/unix/bsd/openbsd/openbsd.factor b/basis/unix/ffi/bsd/openbsd/openbsd.factor similarity index 99% rename from basis/unix/bsd/openbsd/openbsd.factor rename to basis/unix/ffi/bsd/openbsd/openbsd.factor index f48b7c1ac4..076dbdfd24 100644 --- a/basis/unix/bsd/openbsd/openbsd.factor +++ b/basis/unix/ffi/bsd/openbsd/openbsd.factor @@ -1,5 +1,5 @@ USING: alien.c-types alien.syntax classes.struct unix.types ; -IN: unix +IN: unix.ffi CONSTANT: FD_SETSIZE 1024 diff --git a/basis/unix/bsd/openbsd/tags.txt b/basis/unix/ffi/bsd/openbsd/tags.txt similarity index 100% rename from basis/unix/bsd/openbsd/tags.txt rename to basis/unix/ffi/bsd/openbsd/tags.txt diff --git a/basis/unix/bsd/summary.txt b/basis/unix/ffi/bsd/summary.txt similarity index 100% rename from basis/unix/bsd/summary.txt rename to basis/unix/ffi/bsd/summary.txt diff --git a/basis/unix/bsd/tags.txt b/basis/unix/ffi/bsd/tags.txt similarity index 100% rename from basis/unix/bsd/tags.txt rename to basis/unix/ffi/bsd/tags.txt diff --git a/basis/unix/ffi/ffi.factor b/basis/unix/ffi/ffi.factor new file mode 100644 index 0000000000..3882f6fc80 --- /dev/null +++ b/basis/unix/ffi/ffi.factor @@ -0,0 +1,158 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.libraries alien.syntax +classes.struct combinators kernel system unix.time unix.types +vocabs vocabs.loader ; +IN: unix.ffi + +<< + +{ + { [ os linux? ] [ "unix.ffi.linux" require ] } + { [ os bsd? ] [ "unix.ffi.bsd" require ] } + { [ os solaris? ] [ "unix.ffi.solaris" require ] } +} cond + +>> + +CONSTANT: PROT_NONE 0 +CONSTANT: PROT_READ 1 +CONSTANT: PROT_WRITE 2 +CONSTANT: PROT_EXEC 4 + +CONSTANT: MAP_FILE 0 +CONSTANT: MAP_SHARED 1 +CONSTANT: MAP_PRIVATE 2 + +CONSTANT: SEEK_SET 0 +CONSTANT: SEEK_CUR 1 +CONSTANT: SEEK_END 2 + +: MAP_FAILED ( -- alien ) -1 ; inline + +CONSTANT: NGROUPS_MAX 16 + +CONSTANT: DT_UNKNOWN 0 +CONSTANT: DT_FIFO 1 +CONSTANT: DT_CHR 2 +CONSTANT: DT_DIR 4 +CONSTANT: DT_BLK 6 +CONSTANT: DT_REG 8 +CONSTANT: DT_LNK 10 +CONSTANT: DT_SOCK 12 +CONSTANT: DT_WHT 14 + +LIBRARY: libc + +FUNCTION: char* strerror ( int errno ) ; + +STRUCT: group + { gr_name char* } + { gr_passwd char* } + { gr_gid int } + { gr_mem char** } ; + +FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; +FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; +FUNCTION: int chdir ( char* path ) ; +FUNCTION: int chmod ( char* path, mode_t mode ) ; +FUNCTION: int fchmod ( int fd, mode_t mode ) ; +FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ; +FUNCTION: int chroot ( char* path ) ; +FUNCTION: int close ( int fd ) ; +FUNCTION: int closedir ( DIR* dirp ) ; +FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ; +FUNCTION: int dup2 ( int oldd, int newd ) ; +FUNCTION: void endpwent ( ) ; +FUNCTION: int fchdir ( int fd ) ; +FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ; +FUNCTION: int fcntl ( int fd, int cmd, int arg ) ; +FUNCTION: int flock ( int fd, int operation ) ; +FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; +FUNCTION: int futimes ( int id, timeval[2] times ) ; +FUNCTION: char* gai_strerror ( int ecode ) ; +FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; +FUNCTION: char* getcwd ( char* buf, size_t size ) ; +FUNCTION: pid_t getpid ; +FUNCTION: int getdtablesize ; +FUNCTION: gid_t getegid ; +FUNCTION: uid_t geteuid ; +FUNCTION: gid_t getgid ; +FUNCTION: char* getenv ( char* name ) ; + +FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ; +FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ; +FUNCTION: passwd* getpwent ( ) ; +FUNCTION: passwd* getpwuid ( uid_t uid ) ; +FUNCTION: passwd* getpwnam ( char* login ) ; +FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ; +FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; +FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ; +FUNCTION: int getrlimit ( int resource, rlimit* rlp ) ; +FUNCTION: int setrlimit ( int resource, rlimit* rlp ) ; +FUNCTION: int getpriority ( int which, id_t who ) ; +FUNCTION: int setpriority ( int which, id_t who, int prio ) ; +FUNCTION: int getrusage ( int who, rusage* r_usage ) ; +FUNCTION: group* getgrent ; +FUNCTION: int gethostname ( char* name, int len ) ; +FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ; +FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ; +FUNCTION: uid_t getuid ; +FUNCTION: uint htonl ( uint n ) ; +FUNCTION: ushort htons ( ushort n ) ; +! FUNCTION: int issetugid ; +FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ; +FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ; +FUNCTION: int listen ( int s, int backlog ) ; +FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ; +FUNCTION: int mkdir ( char* path, mode_t mode ) ; +FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ; +FUNCTION: int munmap ( void* addr, size_t len ) ; +FUNCTION: uint ntohl ( uint n ) ; +FUNCTION: ushort ntohs ( ushort n ) ; +FUNCTION: int shutdown ( int fd, int how ) ; +FUNCTION: int open ( char* path, int flags, int prot ) ; +FUNCTION: DIR* opendir ( char* path ) ; + +STRUCT: utimbuf + { actime time_t } + { modtime time_t } ; + +FUNCTION: int utime ( char* path, utimbuf* buf ) ; + +FUNCTION: int pclose ( void* file ) ; +FUNCTION: int pipe ( int* filedes ) ; +FUNCTION: void* popen ( char* command, char* type ) ; +FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; + +FUNCTION: dirent* readdir ( DIR* dirp ) ; +FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ; +FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; + +CONSTANT: PATH_MAX 1024 + +FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ; +FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ; +FUNCTION: int rename ( char* from, char* to ) ; +FUNCTION: int rmdir ( char* path ) ; +FUNCTION: int select ( int nfds, void* readfds, void* writefds, void* exceptfds, timeval* timeout ) ; +FUNCTION: ssize_t sendto ( int s, void* buf, size_t len, int flags, sockaddr-in* to, socklen_t tolen ) ; +FUNCTION: int setenv ( char* name, char* value, int overwrite ) ; +FUNCTION: int unsetenv ( char* name ) ; +FUNCTION: int setegid ( gid_t egid ) ; +FUNCTION: int seteuid ( uid_t euid ) ; +FUNCTION: int setgid ( gid_t gid ) ; +FUNCTION: int setgroups ( int ngroups, gid_t* gidset ) ; +FUNCTION: int setregid ( gid_t rgid, gid_t egid ) ; +FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ; +FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ; +FUNCTION: int setuid ( uid_t uid ) ; +FUNCTION: int socket ( int domain, int type, int protocol ) ; +FUNCTION: int symlink ( char* path1, char* path2 ) ; +FUNCTION: int link ( char* path1, char* path2 ) ; +FUNCTION: int system ( char* command ) ; +FUNCTION: int unlink ( char* path ) ; +FUNCTION: int utimes ( char* path, timeval[2] times ) ; +FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; + +"librt" "librt.so" "cdecl" add-library diff --git a/basis/unix/ffi/linux/authors.txt b/basis/unix/ffi/linux/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/ffi/linux/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/ffi/linux/linux.factor b/basis/unix/ffi/linux/linux.factor new file mode 100644 index 0000000000..260796b5e4 --- /dev/null +++ b/basis/unix/ffi/linux/linux.factor @@ -0,0 +1,236 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types alien.syntax classes.struct unix.types ; +IN: unix.ffi + +CONSTANT: MAXPATHLEN 1024 + +CONSTANT: O_RDONLY HEX: 0000 +CONSTANT: O_WRONLY HEX: 0001 +CONSTANT: O_RDWR HEX: 0002 +CONSTANT: O_CREAT HEX: 0040 +CONSTANT: O_EXCL HEX: 0080 +CONSTANT: O_NOCTTY HEX: 0100 +CONSTANT: O_TRUNC HEX: 0200 +CONSTANT: O_APPEND HEX: 0400 +CONSTANT: O_NONBLOCK HEX: 0800 + +ALIAS: O_NDELAY O_NONBLOCK + +CONSTANT: SOL_SOCKET 1 + +CONSTANT: FD_SETSIZE 1024 + +CONSTANT: SO_REUSEADDR 2 +CONSTANT: SO_OOBINLINE 10 +CONSTANT: SO_SNDTIMEO HEX: 15 +CONSTANT: SO_RCVTIMEO HEX: 14 + +CONSTANT: F_SETFD 2 +CONSTANT: FD_CLOEXEC 1 + +CONSTANT: F_SETFL 4 + +STRUCT: addrinfo + { flags int } + { family int } + { socktype int } + { protocol int } + { addrlen socklen_t } + { addr void* } + { canonname char* } + { next addrinfo* } ; + +STRUCT: sockaddr-in + { family ushort } + { port ushort } + { addr in_addr_t } + { unused longlong } ; + +STRUCT: sockaddr-in6 + { family ushort } + { port ushort } + { flowinfo uint } + { addr uchar[16] } + { scopeid uint } ; + +CONSTANT: max-un-path 108 + +STRUCT: sockaddr-un + { family ushort } + { path { char max-un-path } } ; + +CONSTANT: SOCK_STREAM 1 +CONSTANT: SOCK_DGRAM 2 + +CONSTANT: AF_UNSPEC 0 +CONSTANT: AF_UNIX 1 +CONSTANT: AF_INET 2 +CONSTANT: AF_INET6 10 + +ALIAS: PF_UNSPEC AF_UNSPEC +ALIAS: PF_UNIX AF_UNIX +ALIAS: PF_INET AF_INET +ALIAS: PF_INET6 AF_INET6 + +CONSTANT: IPPROTO_TCP 6 +CONSTANT: IPPROTO_UDP 17 + +CONSTANT: AI_PASSIVE 1 + +CONSTANT: SEEK_SET 0 +CONSTANT: SEEK_CUR 1 +CONSTANT: SEEK_END 2 + +STRUCT: passwd + { pw_name char* } + { pw_passwd char* } + { pw_uid uid_t } + { pw_gid gid_t } + { pw_gecos char* } + { pw_dir char* } + { pw_shell char* } ; + +! dirent64 +STRUCT: dirent + { d_ino ulonglong } + { d_off longlong } + { d_reclen ushort } + { d_type uchar } + { d_name char[256] } ; + +FUNCTION: int open64 ( char* path, int flags, int prot ) ; +FUNCTION: dirent* readdir64 ( DIR* dirp ) ; +FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ; + +CONSTANT: EPERM 1 +CONSTANT: ENOENT 2 +CONSTANT: ESRCH 3 +CONSTANT: EINTR 4 +CONSTANT: EIO 5 +CONSTANT: ENXIO 6 +CONSTANT: E2BIG 7 +CONSTANT: ENOEXEC 8 +CONSTANT: EBADF 9 +CONSTANT: ECHILD 10 +CONSTANT: EAGAIN 11 +CONSTANT: ENOMEM 12 +CONSTANT: EACCES 13 +CONSTANT: EFAULT 14 +CONSTANT: ENOTBLK 15 +CONSTANT: EBUSY 16 +CONSTANT: EEXIST 17 +CONSTANT: EXDEV 18 +CONSTANT: ENODEV 19 +CONSTANT: ENOTDIR 20 +CONSTANT: EISDIR 21 +CONSTANT: EINVAL 22 +CONSTANT: ENFILE 23 +CONSTANT: EMFILE 24 +CONSTANT: ENOTTY 25 +CONSTANT: ETXTBSY 26 +CONSTANT: EFBIG 27 +CONSTANT: ENOSPC 28 +CONSTANT: ESPIPE 29 +CONSTANT: EROFS 30 +CONSTANT: EMLINK 31 +CONSTANT: EPIPE 32 +CONSTANT: EDOM 33 +CONSTANT: ERANGE 34 +CONSTANT: EDEADLK 35 +CONSTANT: ENAMETOOLONG 36 +CONSTANT: ENOLCK 37 +CONSTANT: ENOSYS 38 +CONSTANT: ENOTEMPTY 39 +CONSTANT: ELOOP 40 +ALIAS: EWOULDBLOCK EAGAIN +CONSTANT: ENOMSG 42 +CONSTANT: EIDRM 43 +CONSTANT: ECHRNG 44 +CONSTANT: EL2NSYNC 45 +CONSTANT: EL3HLT 46 +CONSTANT: EL3RST 47 +CONSTANT: ELNRNG 48 +CONSTANT: EUNATCH 49 +CONSTANT: ENOCSI 50 +CONSTANT: EL2HLT 51 +CONSTANT: EBADE 52 +CONSTANT: EBADR 53 +CONSTANT: EXFULL 54 +CONSTANT: ENOANO 55 +CONSTANT: EBADRQC 56 +CONSTANT: EBADSLT 57 +ALIAS: EDEADLOCK EDEADLK +CONSTANT: EBFONT 59 +CONSTANT: ENOSTR 60 +CONSTANT: ENODATA 61 +CONSTANT: ETIME 62 +CONSTANT: ENOSR 63 +CONSTANT: ENONET 64 +CONSTANT: ENOPKG 65 +CONSTANT: EREMOTE 66 +CONSTANT: ENOLINK 67 +CONSTANT: EADV 68 +CONSTANT: ESRMNT 69 +CONSTANT: ECOMM 70 +CONSTANT: EPROTO 71 +CONSTANT: EMULTIHOP 72 +CONSTANT: EDOTDOT 73 +CONSTANT: EBADMSG 74 +CONSTANT: EOVERFLOW 75 +CONSTANT: ENOTUNIQ 76 +CONSTANT: EBADFD 77 +CONSTANT: EREMCHG 78 +CONSTANT: ELIBACC 79 +CONSTANT: ELIBBAD 80 +CONSTANT: ELIBSCN 81 +CONSTANT: ELIBMAX 82 +CONSTANT: ELIBEXEC 83 +CONSTANT: EILSEQ 84 +CONSTANT: ERESTART 85 +CONSTANT: ESTRPIPE 86 +CONSTANT: EUSERS 87 +CONSTANT: ENOTSOCK 88 +CONSTANT: EDESTADDRREQ 89 +CONSTANT: EMSGSIZE 90 +CONSTANT: EPROTOTYPE 91 +CONSTANT: ENOPROTOOPT 92 +CONSTANT: EPROTONOSUPPORT 93 +CONSTANT: ESOCKTNOSUPPORT 94 +CONSTANT: EOPNOTSUPP 95 +CONSTANT: EPFNOSUPPORT 96 +CONSTANT: EAFNOSUPPORT 97 +CONSTANT: EADDRINUSE 98 +CONSTANT: EADDRNOTAVAIL 99 +CONSTANT: ENETDOWN 100 +CONSTANT: ENETUNREACH 101 +CONSTANT: ENETRESET 102 +CONSTANT: ECONNABORTED 103 +CONSTANT: ECONNRESET 104 +CONSTANT: ENOBUFS 105 +CONSTANT: EISCONN 106 +CONSTANT: ENOTCONN 107 +CONSTANT: ESHUTDOWN 108 +CONSTANT: ETOOMANYREFS 109 +CONSTANT: ETIMEDOUT 110 +CONSTANT: ECONNREFUSED 111 +CONSTANT: EHOSTDOWN 112 +CONSTANT: EHOSTUNREACH 113 +CONSTANT: EALREADY 114 +CONSTANT: EINPROGRESS 115 +CONSTANT: ESTALE 116 +CONSTANT: EUCLEAN 117 +CONSTANT: ENOTNAM 118 +CONSTANT: ENAVAIL 119 +CONSTANT: EISNAM 120 +CONSTANT: EREMOTEIO 121 +CONSTANT: EDQUOT 122 +CONSTANT: ENOMEDIUM 123 +CONSTANT: EMEDIUMTYPE 124 +CONSTANT: ECANCELED 125 +CONSTANT: ENOKEY 126 +CONSTANT: EKEYEXPIRED 127 +CONSTANT: EKEYREVOKED 128 +CONSTANT: EKEYREJECTED 129 +CONSTANT: EOWNERDEAD 130 +CONSTANT: ENOTRECOVERABLE 131 diff --git a/basis/unix/solaris/authors.txt b/basis/unix/ffi/solaris/authors.txt similarity index 100% rename from basis/unix/solaris/authors.txt rename to basis/unix/ffi/solaris/authors.txt diff --git a/basis/unix/solaris/solaris.factor b/basis/unix/ffi/solaris/solaris.factor similarity index 97% rename from basis/unix/solaris/solaris.factor rename to basis/unix/ffi/solaris/solaris.factor index 1a1a7603f0..d641961a25 100644 --- a/basis/unix/solaris/solaris.factor +++ b/basis/unix/ffi/solaris/solaris.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Patrick Mauritz. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax system kernel layouts ; -IN: unix +IN: unix.ffi ! Solaris. @@ -52,7 +52,7 @@ STRUCT: sockaddr-in6 { addr uchar[16] } { scopeid uint } ; -: max-un-path 108 ; +CONSTANT: max-un-path 108 STRUCT: sockaddr-un { family ushort } diff --git a/basis/unix/debugger/tags.txt b/basis/unix/ffi/solaris/tags.txt similarity index 100% rename from basis/unix/debugger/tags.txt rename to basis/unix/ffi/solaris/tags.txt diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 02d9f37023..a9b80002a8 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -4,10 +4,10 @@ USING: alien alien.c-types alien.strings io.encodings.utf8 io.backend.unix kernel math sequences splitting strings combinators.short-circuit byte-arrays combinators accessors math.parser fry assocs namespaces continuations -unix.users unix.utilities classes.struct ; +unix.users unix.utilities classes.struct unix ; IN: unix.groups -QUALIFIED: unix +QUALIFIED: unix.ffi QUALIFIED: grouping @@ -23,17 +23,21 @@ GENERIC: group-struct ( obj -- group/f ) gr_mem>> utf8 alien>strings ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) - [ \ unix:group ] dip over 4096 + [ \ unix.ffi:group ] dip over 4096 [ ] keep f ; : check-group-struct ( group-struct ptr -- group-struct/f ) *void* [ drop f ] unless ; M: integer group-struct ( id -- group/f ) - (group-struct) [ unix:getgrgid_r unix:io-error ] keep check-group-struct ; + (group-struct) + [ [ unix.ffi:getgrgid_r ] unix-system-call io-error ] keep + check-group-struct ; M: string group-struct ( string -- group/f ) - (group-struct) [ unix:getgrnam_r unix:io-error ] keep check-group-struct ; + (group-struct) + [ [ unix.ffi:getgrnam_r ] unix-system-call io-error ] keep + check-group-struct ; : group-struct>group ( group-struct -- group ) [ \ group new ] dip @@ -64,8 +68,8 @@ PRIVATE> : (user-groups) ( string -- seq ) #! first group is -1337, legacy unix code - -1337 unix:NGROUPS_MAX [ 4 * ] keep - [ unix:getgrouplist unix:io-error ] 2keep + -1337 unix.ffi:NGROUPS_MAX [ 4 * ] keep + [ [ unix.ffi:getgrouplist ] unix-system-call io-error ] 2keep [ 4 tail-slice ] [ *int 1 - ] bi* >groups ; PRIVATE> @@ -79,7 +83,7 @@ M: integer user-groups ( id -- seq ) user-name (user-groups) ; : all-groups ( -- seq ) - [ unix:getgrent dup ] [ \ unix:group memory>struct group-struct>group ] produce nip ; + [ [ unix.ffi:getgrent ] unix-system-call dup ] [ \ unix.ffi:group memory>struct group-struct>group ] produce nip ; : ( -- assoc ) all-groups [ [ id>> ] keep ] H{ } map>assoc ; @@ -87,11 +91,11 @@ M: integer user-groups ( id -- seq ) : with-group-cache ( quot -- ) [ group-cache ] dip with-variable ; inline -: real-group-id ( -- id ) unix:getgid ; inline +: real-group-id ( -- id ) unix.ffi:getgid ; inline : real-group-name ( -- string ) real-group-id group-name ; inline -: effective-group-id ( -- string ) unix:getegid ; inline +: effective-group-id ( -- string ) unix.ffi:getegid ; inline : effective-group-name ( -- string ) effective-group-id group-name ; inline @@ -111,10 +115,10 @@ GENERIC: set-effective-group ( obj -- ) diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 93bf621acd..10bf070e1a 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -1,241 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax alien system classes.struct -unix.types ; -IN: unix - -! Linux. - -CONSTANT: MAXPATHLEN 1024 - -CONSTANT: O_RDONLY HEX: 0000 -CONSTANT: O_WRONLY HEX: 0001 -CONSTANT: O_RDWR HEX: 0002 -CONSTANT: O_CREAT HEX: 0040 -CONSTANT: O_EXCL HEX: 0080 -CONSTANT: O_NOCTTY HEX: 0100 -CONSTANT: O_TRUNC HEX: 0200 -CONSTANT: O_APPEND HEX: 0400 -CONSTANT: O_NONBLOCK HEX: 0800 - -ALIAS: O_NDELAY O_NONBLOCK - -CONSTANT: SOL_SOCKET 1 - -CONSTANT: FD_SETSIZE 1024 - -CONSTANT: SO_REUSEADDR 2 -CONSTANT: SO_OOBINLINE 10 -CONSTANT: SO_SNDTIMEO HEX: 15 -CONSTANT: SO_RCVTIMEO HEX: 14 - -CONSTANT: F_SETFD 2 -CONSTANT: FD_CLOEXEC 1 - -CONSTANT: F_SETFL 4 - -STRUCT: addrinfo - { flags int } - { family int } - { socktype int } - { protocol int } - { addrlen socklen_t } - { addr void* } - { canonname char* } - { next addrinfo* } ; - -STRUCT: sockaddr-in - { family ushort } - { port ushort } - { addr in_addr_t } - { unused longlong } ; - -STRUCT: sockaddr-in6 - { family ushort } - { port ushort } - { flowinfo uint } - { addr uchar[16] } - { scopeid uint } ; - -CONSTANT: max-un-path 108 - -STRUCT: sockaddr-un - { family ushort } - { path { char max-un-path } } ; - -CONSTANT: SOCK_STREAM 1 -CONSTANT: SOCK_DGRAM 2 - -CONSTANT: AF_UNSPEC 0 -CONSTANT: AF_UNIX 1 -CONSTANT: AF_INET 2 -CONSTANT: AF_INET6 10 - -ALIAS: PF_UNSPEC AF_UNSPEC -ALIAS: PF_UNIX AF_UNIX -ALIAS: PF_INET AF_INET -ALIAS: PF_INET6 AF_INET6 - -CONSTANT: IPPROTO_TCP 6 -CONSTANT: IPPROTO_UDP 17 - -CONSTANT: AI_PASSIVE 1 - -CONSTANT: SEEK_SET 0 -CONSTANT: SEEK_CUR 1 -CONSTANT: SEEK_END 2 - -STRUCT: passwd - { pw_name char* } - { pw_passwd char* } - { pw_uid uid_t } - { pw_gid gid_t } - { pw_gecos char* } - { pw_dir char* } - { pw_shell char* } ; - -! dirent64 -STRUCT: dirent - { d_ino ulonglong } - { d_off longlong } - { d_reclen ushort } - { d_type uchar } - { d_name char[256] } ; - -FUNCTION: int open64 ( char* path, int flags, int prot ) ; -FUNCTION: dirent* readdir64 ( DIR* dirp ) ; -FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ; +USING: system unix unix.ffi unix.ffi.linux ; +IN: unix.linux M: linux open-file [ open64 ] unix-system-call ; - -CONSTANT: EPERM 1 -CONSTANT: ENOENT 2 -CONSTANT: ESRCH 3 -CONSTANT: EINTR 4 -CONSTANT: EIO 5 -CONSTANT: ENXIO 6 -CONSTANT: E2BIG 7 -CONSTANT: ENOEXEC 8 -CONSTANT: EBADF 9 -CONSTANT: ECHILD 10 -CONSTANT: EAGAIN 11 -CONSTANT: ENOMEM 12 -CONSTANT: EACCES 13 -CONSTANT: EFAULT 14 -CONSTANT: ENOTBLK 15 -CONSTANT: EBUSY 16 -CONSTANT: EEXIST 17 -CONSTANT: EXDEV 18 -CONSTANT: ENODEV 19 -CONSTANT: ENOTDIR 20 -CONSTANT: EISDIR 21 -CONSTANT: EINVAL 22 -CONSTANT: ENFILE 23 -CONSTANT: EMFILE 24 -CONSTANT: ENOTTY 25 -CONSTANT: ETXTBSY 26 -CONSTANT: EFBIG 27 -CONSTANT: ENOSPC 28 -CONSTANT: ESPIPE 29 -CONSTANT: EROFS 30 -CONSTANT: EMLINK 31 -CONSTANT: EPIPE 32 -CONSTANT: EDOM 33 -CONSTANT: ERANGE 34 -CONSTANT: EDEADLK 35 -CONSTANT: ENAMETOOLONG 36 -CONSTANT: ENOLCK 37 -CONSTANT: ENOSYS 38 -CONSTANT: ENOTEMPTY 39 -CONSTANT: ELOOP 40 -ALIAS: EWOULDBLOCK EAGAIN -CONSTANT: ENOMSG 42 -CONSTANT: EIDRM 43 -CONSTANT: ECHRNG 44 -CONSTANT: EL2NSYNC 45 -CONSTANT: EL3HLT 46 -CONSTANT: EL3RST 47 -CONSTANT: ELNRNG 48 -CONSTANT: EUNATCH 49 -CONSTANT: ENOCSI 50 -CONSTANT: EL2HLT 51 -CONSTANT: EBADE 52 -CONSTANT: EBADR 53 -CONSTANT: EXFULL 54 -CONSTANT: ENOANO 55 -CONSTANT: EBADRQC 56 -CONSTANT: EBADSLT 57 -ALIAS: EDEADLOCK EDEADLK -CONSTANT: EBFONT 59 -CONSTANT: ENOSTR 60 -CONSTANT: ENODATA 61 -CONSTANT: ETIME 62 -CONSTANT: ENOSR 63 -CONSTANT: ENONET 64 -CONSTANT: ENOPKG 65 -CONSTANT: EREMOTE 66 -CONSTANT: ENOLINK 67 -CONSTANT: EADV 68 -CONSTANT: ESRMNT 69 -CONSTANT: ECOMM 70 -CONSTANT: EPROTO 71 -CONSTANT: EMULTIHOP 72 -CONSTANT: EDOTDOT 73 -CONSTANT: EBADMSG 74 -CONSTANT: EOVERFLOW 75 -CONSTANT: ENOTUNIQ 76 -CONSTANT: EBADFD 77 -CONSTANT: EREMCHG 78 -CONSTANT: ELIBACC 79 -CONSTANT: ELIBBAD 80 -CONSTANT: ELIBSCN 81 -CONSTANT: ELIBMAX 82 -CONSTANT: ELIBEXEC 83 -CONSTANT: EILSEQ 84 -CONSTANT: ERESTART 85 -CONSTANT: ESTRPIPE 86 -CONSTANT: EUSERS 87 -CONSTANT: ENOTSOCK 88 -CONSTANT: EDESTADDRREQ 89 -CONSTANT: EMSGSIZE 90 -CONSTANT: EPROTOTYPE 91 -CONSTANT: ENOPROTOOPT 92 -CONSTANT: EPROTONOSUPPORT 93 -CONSTANT: ESOCKTNOSUPPORT 94 -CONSTANT: EOPNOTSUPP 95 -CONSTANT: EPFNOSUPPORT 96 -CONSTANT: EAFNOSUPPORT 97 -CONSTANT: EADDRINUSE 98 -CONSTANT: EADDRNOTAVAIL 99 -CONSTANT: ENETDOWN 100 -CONSTANT: ENETUNREACH 101 -CONSTANT: ENETRESET 102 -CONSTANT: ECONNABORTED 103 -CONSTANT: ECONNRESET 104 -CONSTANT: ENOBUFS 105 -CONSTANT: EISCONN 106 -CONSTANT: ENOTCONN 107 -CONSTANT: ESHUTDOWN 108 -CONSTANT: ETOOMANYREFS 109 -CONSTANT: ETIMEDOUT 110 -CONSTANT: ECONNREFUSED 111 -CONSTANT: EHOSTDOWN 112 -CONSTANT: EHOSTUNREACH 113 -CONSTANT: EALREADY 114 -CONSTANT: EINPROGRESS 115 -CONSTANT: ESTALE 116 -CONSTANT: EUCLEAN 117 -CONSTANT: ENOTNAM 118 -CONSTANT: ENAVAIL 119 -CONSTANT: EISNAM 120 -CONSTANT: EREMOTEIO 121 -CONSTANT: EDQUOT 122 -CONSTANT: ENOMEDIUM 123 -CONSTANT: EMEDIUMTYPE 124 -CONSTANT: ECANCELED 125 -CONSTANT: ENOKEY 126 -CONSTANT: EKEYEXPIRED 127 -CONSTANT: EKEYREVOKED 128 -CONSTANT: EKEYREJECTED 129 -CONSTANT: EOWNERDEAD 130 -CONSTANT: ENOTRECOVERABLE 131 diff --git a/basis/unix/solaris/tags.txt b/basis/unix/solaris/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/unix/solaris/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index a2104dcb33..4e6b2dfb21 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -1,5 +1,5 @@ USING: alien.c-types arrays accessors combinators classes.struct -alien.syntax unix.time unix.types ; +alien.syntax unix.time unix.types unix.ffi ; IN: unix.stat ! Mac OS X diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index e83d2d40a0..56c8989895 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -3,7 +3,7 @@ USING: alien.c-types io.encodings.utf8 io.encodings.string kernel sequences unix.stat accessors unix combinators math grouping system alien.strings math.bitwise alien.syntax -unix.types classes.struct ; +unix.types classes.struct unix.ffi ; IN: unix.statfs.macosx CONSTANT: MNT_RDONLY HEX: 00000001 diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 86b8646bdd..4e77a41713 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -6,40 +6,9 @@ alien.syntax byte-arrays classes.struct combinators combinators.short-circuit combinators.smart continuations generalizations io kernel libc locals macros math namespaces sequences stack-checker strings system unix.time unix.types -vocabs vocabs.loader ; +vocabs vocabs.loader unix.ffi ; IN: unix -CONSTANT: PROT_NONE 0 -CONSTANT: PROT_READ 1 -CONSTANT: PROT_WRITE 2 -CONSTANT: PROT_EXEC 4 - -CONSTANT: MAP_FILE 0 -CONSTANT: MAP_SHARED 1 -CONSTANT: MAP_PRIVATE 2 - -CONSTANT: SEEK_SET 0 -CONSTANT: SEEK_CUR 1 -CONSTANT: SEEK_END 2 - -: MAP_FAILED ( -- alien ) -1 ; inline - -CONSTANT: NGROUPS_MAX 16 - -CONSTANT: DT_UNKNOWN 0 -CONSTANT: DT_FIFO 1 -CONSTANT: DT_CHR 2 -CONSTANT: DT_DIR 4 -CONSTANT: DT_BLK 6 -CONSTANT: DT_REG 8 -CONSTANT: DT_LNK 10 -CONSTANT: DT_SOCK 12 -CONSTANT: DT_WHT 14 - -LIBRARY: libc - -FUNCTION: char* strerror ( int errno ) ; - ERROR: unix-error errno message ; : (io-error) ( -- * ) errno dup strerror unix-error ; @@ -79,109 +48,14 @@ MACRO:: unix-system-call ( quot -- ) HOOK: open-file os ( path flags mode -- fd ) -<< - -{ - { [ os linux? ] [ "unix.linux" require ] } - { [ os bsd? ] [ "unix.bsd" require ] } - { [ os solaris? ] [ "unix.solaris" require ] } -} cond - -"debugger" vocab [ - "unix.debugger" require -] when - ->> - -STRUCT: group - { gr_name char* } - { gr_passwd char* } - { gr_gid int } - { gr_mem char** } ; - -FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; -FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; -FUNCTION: int chdir ( char* path ) ; -FUNCTION: int chmod ( char* path, mode_t mode ) ; -FUNCTION: int fchmod ( int fd, mode_t mode ) ; -FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ; -FUNCTION: int chroot ( char* path ) ; - -FUNCTION: int close ( int fd ) ; -FUNCTION: int closedir ( DIR* dirp ) ; - : close-file ( fd -- ) [ close ] unix-system-call drop ; -FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ; -FUNCTION: int dup2 ( int oldd, int newd ) ; -! FUNCTION: int dup ( int oldd ) ; : _exit ( status -- * ) #! We throw to give this a terminating stack effect. int f "_exit" { int } alien-invoke "Exit failed" throw ; -FUNCTION: void endpwent ( ) ; -FUNCTION: int fchdir ( int fd ) ; -FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ; -FUNCTION: int fcntl ( int fd, int cmd, int arg ) ; -FUNCTION: int flock ( int fd, int operation ) ; -FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; -FUNCTION: int futimes ( int id, timeval[2] times ) ; -FUNCTION: char* gai_strerror ( int ecode ) ; -FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; -FUNCTION: char* getcwd ( char* buf, size_t size ) ; -FUNCTION: pid_t getpid ; -FUNCTION: int getdtablesize ; -FUNCTION: gid_t getegid ; -FUNCTION: uid_t geteuid ; -FUNCTION: gid_t getgid ; -FUNCTION: char* getenv ( char* name ) ; - -FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ; -FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ; -FUNCTION: passwd* getpwent ( ) ; -FUNCTION: passwd* getpwuid ( uid_t uid ) ; -FUNCTION: passwd* getpwnam ( char* login ) ; -FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ; -FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; -FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ; -FUNCTION: int getrlimit ( int resource, rlimit* rlp ) ; -FUNCTION: int setrlimit ( int resource, rlimit* rlp ) ; - -FUNCTION: int getpriority ( int which, id_t who ) ; -FUNCTION: int setpriority ( int which, id_t who, int prio ) ; - -FUNCTION: int getrusage ( int who, rusage* r_usage ) ; - -FUNCTION: group* getgrent ; -FUNCTION: int gethostname ( char* name, int len ) ; -FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ; -FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ; -FUNCTION: uid_t getuid ; -FUNCTION: uint htonl ( uint n ) ; -FUNCTION: ushort htons ( ushort n ) ; -! FUNCTION: int issetugid ; -FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ; -FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ; -FUNCTION: int listen ( int s, int backlog ) ; -FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ; -FUNCTION: int mkdir ( char* path, mode_t mode ) ; -FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ; -FUNCTION: int munmap ( void* addr, size_t len ) ; -FUNCTION: uint ntohl ( uint n ) ; -FUNCTION: ushort ntohs ( ushort n ) ; -FUNCTION: int shutdown ( int fd, int how ) ; - -FUNCTION: int open ( char* path, int flags, int prot ) ; M: unix open-file [ open ] unix-system-call ; -FUNCTION: DIR* opendir ( char* path ) ; - -STRUCT: utimbuf - { actime time_t } - { modtime time_t } ; - -FUNCTION: int utime ( char* path, utimbuf* buf ) ; - : touch ( filename -- ) f [ utime ] unix-system-call drop ; : change-file-times ( filename access modification -- ) @@ -190,50 +64,18 @@ FUNCTION: int utime ( char* path, utimbuf* buf ) ; swap >>actime [ utime ] unix-system-call drop ; -FUNCTION: int pclose ( void* file ) ; -FUNCTION: int pipe ( int* filedes ) ; -FUNCTION: void* popen ( char* command, char* type ) ; -FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; - -FUNCTION: dirent* readdir ( DIR* dirp ) ; -FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ; -FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; - -CONSTANT: PATH_MAX 1024 - : read-symbolic-link ( path -- path ) PATH_MAX dup [ PATH_MAX [ readlink ] unix-system-call ] dip swap head-slice >string ; -FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ; -FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ; -FUNCTION: int rename ( char* from, char* to ) ; -FUNCTION: int rmdir ( char* path ) ; -FUNCTION: int select ( int nfds, void* readfds, void* writefds, void* exceptfds, timeval* timeout ) ; -FUNCTION: ssize_t sendto ( int s, void* buf, size_t len, int flags, sockaddr-in* to, socklen_t tolen ) ; -FUNCTION: int setenv ( char* name, char* value, int overwrite ) ; -FUNCTION: int unsetenv ( char* name ) ; -FUNCTION: int setegid ( gid_t egid ) ; -FUNCTION: int seteuid ( uid_t euid ) ; -FUNCTION: int setgid ( gid_t gid ) ; -FUNCTION: int setgroups ( int ngroups, gid_t* gidset ) ; -FUNCTION: int setregid ( gid_t rgid, gid_t egid ) ; -FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ; -FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ; -FUNCTION: int setuid ( uid_t uid ) ; -FUNCTION: int socket ( int domain, int type, int protocol ) ; -FUNCTION: int symlink ( char* path1, char* path2 ) ; -FUNCTION: int link ( char* path1, char* path2 ) ; -FUNCTION: int system ( char* command ) ; - -FUNCTION: int unlink ( char* path ) ; - : unlink-file ( path -- ) [ unlink ] unix-system-call drop ; -FUNCTION: int utimes ( char* path, timeval[2] times ) ; +<< -FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; +"debugger" vocab [ + "unix.debugger" require +] when -"librt" "librt.so" "cdecl" add-library +>> diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 09119ff0cc..b279069c59 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -4,9 +4,9 @@ USING: alien alien.c-types alien.strings io.encodings.utf8 io.backend.unix kernel math sequences splitting strings combinators.short-circuit grouping byte-arrays combinators accessors math.parser fry assocs namespaces continuations -vocabs.loader system classes.struct ; +vocabs.loader system classes.struct unix ; IN: unix.users -QUALIFIED: unix +QUALIFIED: unix.ffi TUPLE: passwd user-name password uid gid gecos dir shell ; @@ -31,13 +31,13 @@ M: unix passwd>new-passwd ( passwd -- seq ) } cleave ; : with-pwent ( quot -- ) - [ unix:endpwent ] [ ] cleanup ; inline + [ unix.ffi:endpwent ] [ ] cleanup ; inline PRIVATE> : all-users ( -- seq ) [ - [ unix:getpwent dup ] [ unix:passwd memory>struct passwd>new-passwd ] produce nip + [ unix.ffi:getpwent dup ] [ unix.ffi:passwd memory>struct passwd>new-passwd ] produce nip ] with-pwent ; SYMBOL: user-cache @@ -52,10 +52,10 @@ GENERIC: user-passwd ( obj -- passwd/f ) M: integer user-passwd ( id -- passwd/f ) user-cache get - [ at ] [ unix:getpwuid [ unix:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ; + [ at ] [ unix.ffi:getpwuid [ unix.ffi:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ; M: string user-passwd ( string -- passwd/f ) - unix:getpwnam dup [ unix:passwd memory>struct passwd>new-passwd ] when ; + unix.ffi:getpwnam dup [ unix.ffi:passwd memory>struct passwd>new-passwd ] when ; : user-name ( id -- string ) dup user-passwd @@ -65,13 +65,13 @@ M: string user-passwd ( string -- passwd/f ) user-passwd uid>> ; : real-user-id ( -- id ) - unix:getuid ; inline + unix.ffi:getuid ; inline : real-user-name ( -- string ) real-user-id user-name ; inline : effective-user-id ( -- id ) - unix:geteuid ; inline + unix.ffi:geteuid ; inline : effective-user-name ( -- string ) effective-user-id user-name ; inline @@ -93,10 +93,10 @@ GENERIC: set-effective-user ( string/id -- ) From b7b84fc5b716473d4faa3357dd889be086ad1171 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 Jan 2010 22:57:51 -0600 Subject: [PATCH 28/72] fix using --- basis/io/files/unique/unix/unix.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/files/unique/unix/unix.factor b/basis/io/files/unique/unix/unix.factor index 9f35f440c7..ec72d9128b 100644 --- a/basis/io/files/unique/unix/unix.factor +++ b/basis/io/files/unique/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.ports io.backend.unix math.bitwise -unix system io.files.unique ; +unix system io.files.unique unix.ffi ; IN: io.files.unique.unix : open-unique-flags ( -- flags ) From eacb1412e21f1965da54332d27dc279ed538f360 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 21 Jan 2010 00:42:07 -0600 Subject: [PATCH 29/72] Mason requires a hostname now (things break if this is an empty string) --- extra/mason/common/common.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index cac4180abd..912cd48c79 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -8,8 +8,10 @@ calendar.format arrays mason.config locals debugger fry continuations strings io.sockets ; IN: mason.common +ERROR: no-host-name ; + : short-host-name ( -- string ) - host-name "." split1 drop ; + host-name "." split1 drop [ no-host-name ] unless* ; SYMBOL: current-git-id From 3c09c7052c4163a75583dd173f692b929d434e32 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 21 Jan 2010 13:44:23 -0600 Subject: [PATCH 30/72] Fix using --- basis/io/directories/unix/linux/linux.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor index c5678fae9c..932cbe230b 100644 --- a/basis/io/directories/unix/linux/linux.factor +++ b/basis/io/directories/unix/linux/linux.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types io.directories.unix kernel system unix -classes.struct ; +classes.struct unix.ffi ; IN: io.directories.unix.linux M: unix find-next-file ( DIR* -- dirent ) From 40cf302d2d7fe4a2960169605f8042a9f1fb1eab Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 01:17:18 -0600 Subject: [PATCH 31/72] Fix image save on Windows --- core/memory/memory.factor | 2 +- vm/image.cpp | 13 +++++++------ vm/os-windows.hpp | 6 +++--- 3 files changed, 11 insertions(+), 10 deletions(-) diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 0fba4dee77..a1e977f553 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -8,7 +8,7 @@ IN: memory [ all-instances ] dip filter ; inline : saving-path ( path -- saving-path path ) - [ ".saving" append-path ] keep + [ ".saving" append ] keep [ native-string>alien ] bi@ ; : save-image ( path -- ) diff --git a/vm/image.cpp b/vm/image.cpp index bfc9f3daca..ba9fb4e6e6 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -276,7 +276,7 @@ bool factor_vm::save_image(const vm_char *saving_filename, const vm_char *filena file = OPEN_WRITE(saving_filename); if(file == NULL) { - std::cout << "Cannot open image file: " << filename << std::endl; + std::cout << "Cannot open image file: " << saving_filename << std::endl; std::cout << strerror(errno) << std::endl; return false; } @@ -303,9 +303,10 @@ bool factor_vm::save_image(const vm_char *saving_filename, const vm_char *filena if(safe_fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false; if(safe_fclose(file)) ok = false; - MOVE_FILE(saving_filename,filename); if(!ok) std::cout << "save-image failed: " << strerror(errno) << std::endl; + else + MOVE_FILE(saving_filename,filename); return ok; } @@ -315,10 +316,10 @@ void factor_vm::primitive_save_image() /* do a full GC to push everything into tenured space */ primitive_compact_gc(); - data_root path1(ctx->pop(),this); - path1.untag_check(this); data_root path2(ctx->pop(),this); path2.untag_check(this); + data_root path1(ctx->pop(),this); + path1.untag_check(this); save_image((vm_char *)(path1.untagged() + 1 ),(vm_char *)(path2.untagged() + 1)); } @@ -327,10 +328,10 @@ void factor_vm::primitive_save_image_and_exit() /* We unbox this before doing anything else. This is the only point where we might throw an error, so we have to throw an error here since later steps destroy the current image. */ - data_root path1(ctx->pop(),this); - path1.untag_check(this); data_root path2(ctx->pop(),this); path2.untag_check(this); + data_root path1(ctx->pop(),this); + path1.untag_check(this); /* strip out special_objects data which is set on startup anyway */ for(cell i = 0; i < special_object_count; i++) diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 0569d85b61..30e3eea9c9 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -39,10 +39,10 @@ typedef wchar_t vm_char; #define OPEN_READ(path) _wfopen((path),L"rb") #define OPEN_WRITE(path) _wfopen((path),L"wb") -#define MOVE_FILE(path1,path2) \ +#define MOVE_FILE(path1,path2)\ do {\ - if(MoveFile((path1),(path2)) == 0)\ - general_error(ERROR_IO,tag_fixnum(GetLastError()),false_object,NULL);\ + if(MoveFileEx((path1),(path2),MOVEFILE_REPLACE_EXISTING) == false)\ + std::cout << "MoveFile() failed: error " << GetLastError() << std::endl;\ } while(0) /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ From 51c9bd040db40c23af5e035d4aee51c58505c322 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 01:22:14 -0600 Subject: [PATCH 32/72] Delete .lib objects from Visual Studio if they exist. gcc doesn't build them, yet tries to use them if they exist... --- GNUmakefile | 2 ++ 1 file changed, 2 insertions(+) diff --git a/GNUmakefile b/GNUmakefile index 4447dfbede..c4796de63b 100755 --- a/GNUmakefile +++ b/GNUmakefile @@ -213,6 +213,8 @@ endif clean: rm -f vm/*.o rm -f factor.dll + rm -f factor.lib + rm -f factor.dll.lib rm -f libfactor.* rm -f libfactor-ffi-test.* rm -f Factor.app/Contents/Frameworks/libfactor.dylib From f7ee9223aeba8418bf5ecfa6490d6a75674ca4a3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 13:24:50 -0600 Subject: [PATCH 33/72] Fix using --- basis/specialized-arrays/specialized-arrays-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index c7e1285689..c25f8ae3b1 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -4,7 +4,8 @@ specialized-arrays.private sequences alien.c-types accessors kernel arrays combinators compiler compiler.units classes.struct combinators.smart compiler.tree.debugger math libc destructors sequences.private multiline eval words vocabs namespaces -assocs prettyprint alien.data math.vectors definitions ; +assocs prettyprint alien.data math.vectors definitions +compiler.test ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: int From bbff91e0ed3db510493b198dd5508917f3a07bb8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 14:45:15 -0600 Subject: [PATCH 34/72] Fix load error --- basis/unix/ffi/bsd/netbsd/structs/structs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/ffi/bsd/netbsd/structs/structs.factor b/basis/unix/ffi/bsd/netbsd/structs/structs.factor index 1882fa830b..40cc9076ae 100644 --- a/basis/unix/ffi/bsd/netbsd/structs/structs.factor +++ b/basis/unix/ffi/bsd/netbsd/structs/structs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax unix.time unix.types -unix.types.netbsd classes.struct ; +unix.types.netbsd classes.struct unix.ffi ; IN: unix STRUCT: sockaddr_storage From f144a36ad0cf3754afd401d01e4b6d28460ee64f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 14:49:32 -0600 Subject: [PATCH 35/72] Move netbsd.structs into netbsd --- basis/unix/ffi/bsd/netbsd/netbsd.factor | 24 ++++++++++++++- .../ffi/bsd/netbsd/structs/structs.factor | 30 ------------------- basis/unix/ffi/bsd/netbsd/structs/tags.txt | 1 - 3 files changed, 23 insertions(+), 32 deletions(-) delete mode 100644 basis/unix/ffi/bsd/netbsd/structs/structs.factor delete mode 100644 basis/unix/ffi/bsd/netbsd/structs/tags.txt diff --git a/basis/unix/ffi/bsd/netbsd/netbsd.factor b/basis/unix/ffi/bsd/netbsd/netbsd.factor index 0aee585b48..e519652421 100644 --- a/basis/unix/ffi/bsd/netbsd/netbsd.factor +++ b/basis/unix/ffi/bsd/netbsd/netbsd.factor @@ -138,4 +138,26 @@ CONSTANT: _SS_MAXSIZE 128 : _SS_PAD2SIZE ( -- n ) _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline -"unix.ffi.bsd.netbsd.structs" require +STRUCT: sockaddr_storage + { ss_len __uint8_t } + { ss_family sa_family_t } + { __ss_pad1 { char _SS_PAD1SIZE } } + { __ss_align __int64_t } + { __ss_pad2 { char _SS_PAD2SIZE } } ; + +STRUCT: exit_struct + { e_termination uint16_t } + { e_exit uint16_t } ; + +STRUCT: utmpx + { ut_user { char _UTX_USERSIZE } } + { ut_id { char _UTX_IDSIZE } } + { ut_line { char _UTX_LINESIZE } } + { ut_host { char _UTX_HOSTSIZE } } + { ut_session uint16_t } + { ut_type uint16_t } + { ut_pid pid_t } + { ut_exit exit_struct } + { ut_ss sockaddr_storage } + { ut_tv timeval } + { ut_pad { uint32_t 10 } } ; diff --git a/basis/unix/ffi/bsd/netbsd/structs/structs.factor b/basis/unix/ffi/bsd/netbsd/structs/structs.factor deleted file mode 100644 index 40cc9076ae..0000000000 --- a/basis/unix/ffi/bsd/netbsd/structs/structs.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax unix.time unix.types -unix.types.netbsd classes.struct unix.ffi ; -IN: unix - -STRUCT: sockaddr_storage - { ss_len __uint8_t } - { ss_family sa_family_t } - { __ss_pad1 { char _SS_PAD1SIZE } } - { __ss_align __int64_t } - { __ss_pad2 { char _SS_PAD2SIZE } } ; - -STRUCT: exit_struct - { e_termination uint16_t } - { e_exit uint16_t } ; - -STRUCT: utmpx - { ut_user { char _UTX_USERSIZE } } - { ut_id { char _UTX_IDSIZE } } - { ut_line { char _UTX_LINESIZE } } - { ut_host { char _UTX_HOSTSIZE } } - { ut_session uint16_t } - { ut_type uint16_t } - { ut_pid pid_t } - { ut_exit exit_struct } - { ut_ss sockaddr_storage } - { ut_tv timeval } - { ut_pad { uint32_t 10 } } ; - diff --git a/basis/unix/ffi/bsd/netbsd/structs/tags.txt b/basis/unix/ffi/bsd/netbsd/structs/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/unix/ffi/bsd/netbsd/structs/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable From 8c1d202b4c0fd303cb628f588050197159c00dbc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 15:00:53 -0600 Subject: [PATCH 36/72] Rename accumulator to collector, pusher to selector --- .../cfg/ssa/construction/tdmsc/tdmsc.factor | 6 ++--- .../stacks/uninitialized/uninitialized.factor | 2 +- .../combinators/combinators.factor | 2 +- basis/db/db.factor | 2 +- basis/dlists/dlists.factor | 2 +- basis/documents/documents.factor | 2 +- basis/images/jpeg/jpeg.factor | 2 +- basis/io/directories/search/search.factor | 6 ++--- basis/lists/lists.factor | 2 +- basis/regexp/regexp.factor | 2 +- basis/sequences/deep/deep.factor | 2 +- .../generalizations/generalizations.factor | 8 +++---- core/assocs/assocs.factor | 2 +- core/io/io.factor | 2 +- core/make/make-docs.factor | 4 ++-- core/sequences/sequences-docs.factor | 24 +++++++++---------- core/sequences/sequences.factor | 20 ++++++++-------- extra/mongodb/operations/operations.factor | 2 +- misc/vim/syntax/factor.vim | 2 +- 19 files changed, 47 insertions(+), 47 deletions(-) diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor index 647c97d6c3..e2f2e5d41a 100644 --- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +!r Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs bit-arrays bit-sets fry hashtables hints kernel locals math namespaces sequences sets @@ -86,7 +86,7 @@ SYMBOLS: visited merge-sets levels again? ; cfg get reverse-post-order ; inline : filter-by ( flags seq -- seq' ) - [ drop ] pusher [ 2each ] dip ; + [ drop ] selector [ 2each ] dip ; HINTS: filter-by { bit-array object } ; @@ -107,4 +107,4 @@ PRIVATE> ] 2each ; inline : merge-set ( bbs -- bbs' ) - (merge-set) filter-by ; \ No newline at end of file + (merge-set) filter-by ; diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index e5fbfa6c40..5b2bbf3765 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -55,7 +55,7 @@ M: insn visit-insn drop ; 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ; : (uninitialized-locs) ( seq quot -- seq' ) - [ [ drop 0 = ] pusher [ each-index ] dip ] dip map ; inline + [ [ drop 0 = ] selector [ each-index ] dip ] dip map ; inline PRIVATE> diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor index 918b3c5ba0..44cad8de61 100644 --- a/basis/concurrency/combinators/combinators.factor +++ b/basis/concurrency/combinators/combinators.factor @@ -22,7 +22,7 @@ PRIVATE> ] (parallel-each) ; inline : parallel-filter ( seq quot -- newseq ) - over [ pusher [ parallel-each ] dip ] dip like ; inline + over [ selector [ parallel-each ] dip ] dip like ; inline > @ ] dlist-each-node ; inline : dlist>seq ( dlist -- seq ) - [ ] accumulator [ dlist-each ] dip ; + [ ] collector [ dlist-each ] dip ; : 1dlist ( obj -- dlist ) [ push-front ] keep ; diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index aef4f4de78..dcd1bf5820 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -61,7 +61,7 @@ TUPLE: document < model locs undos redos inside-undo? ; ] if ; inline : map-lines ( from to quot -- results ) - accumulator [ each-line ] dip ; inline + collector [ each-line ] dip ; inline : start/end-on-line ( from to line# document -- n1 n2 ) [ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 9a67d43e7d..a7f08504bb 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -351,7 +351,7 @@ SINGLETONS: YUV420 YUV444 Y MAGIC! ; [ bitstream>> ] [ [ [ ] with map ] change-huff-tables drop ] bi jpeg> components>> [ fetch-tables ] each - [ decode-macroblock 2array ] accumulator + [ decode-macroblock 2array ] collector [ all-macroblocks ] dip jpeg> setup-bitmap draw-macroblocks jpeg> bitmap>> 3 [ color-transform ] map! drop diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 4356a0b988..28d7f63d87 100644 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -64,17 +64,17 @@ PRIVATE> setup-traversal iterate-directory-entries drop ; inline : recursive-directory-files ( path bfs? -- paths ) - [ ] accumulator [ each-file ] dip ; inline + [ ] collector [ each-file ] dip ; inline : recursive-directory-entries ( path bfs? -- directory-entries ) - [ ] accumulator [ each-directory-entry ] dip ; inline + [ ] collector [ each-directory-entry ] dip ; inline : find-file ( path bfs? quot -- path/f ) [ ] dip [ keep and ] curry iterate-directory ; inline : find-all-files ( path quot -- paths/f ) - [ f ] dip pusher + [ f ] dip selector [ [ f ] compose iterate-directory drop ] dip ; inline ERROR: file-not-found path bfs? quot ; diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index f3475f960b..29adcd47d6 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -88,7 +88,7 @@ PRIVATE> nil [ swons ] reduce ; : lmap>array ( list quot -- array ) - accumulator [ leach ] dip { } like ; inline + collector [ leach ] dip { } like ; inline : list>array ( list -- array ) [ ] lmap>array ; diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index e9a86516ca..0b387acd2a 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -84,7 +84,7 @@ PRIVATE> [ prepare-match-iterator ] dip (each-match) ; inline : map-matches ( string regexp quot: ( start end string -- obj ) -- seq ) - accumulator [ each-match ] dip >array ; inline + collector [ each-match ] dip >array ; inline : all-matching-slices ( string regexp -- seq ) [ slice boa ] map-matches ; diff --git a/basis/sequences/deep/deep.factor b/basis/sequences/deep/deep.factor index 8e01025b94..c79d0b2002 100644 --- a/basis/sequences/deep/deep.factor +++ b/basis/sequences/deep/deep.factor @@ -21,7 +21,7 @@ M: object branch? drop f ; [ '[ _ deep-map ] map ] [ drop ] if ; inline recursive : deep-filter ( obj quot: ( elt -- ? ) -- seq ) - over [ pusher [ deep-each ] dip ] dip + over [ selector [ deep-each ] dip ] dip dup branch? [ like ] [ drop ] if ; inline recursive : (deep-find) ( obj quot: ( elt -- ? ) -- elt ? ) diff --git a/basis/sequences/generalizations/generalizations.factor b/basis/sequences/generalizations/generalizations.factor index 210b27f3f3..f49dc8a4e7 100644 --- a/basis/sequences/generalizations/generalizations.factor +++ b/basis/sequences/generalizations/generalizations.factor @@ -58,19 +58,19 @@ MACRO: (ncollect) ( n -- ) : mnmap ( m*seq quot m n -- result*n ) 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline -: naccumulator-for ( quot ...exemplar n -- quot' vec... ) +: ncollector-for ( quot ...exemplar n -- quot' vec... ) 5 dupn '[ [ [ length ] keep new-resizable ] _ napply [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep ] call ; inline -: naccumulator ( quot n -- quot' vec... ) - [ V{ } swap dupn ] keep naccumulator-for ; inline +: ncollector ( quot n -- quot' vec... ) + [ V{ } swap dupn ] keep ncollector-for ; inline : nproduce-as ( pred quot ...exemplar n -- seq... ) 7 dupn '[ _ ndup - [ _ naccumulator-for [ while ] _ ndip ] + [ _ ncollector-for [ while ] _ ndip ] _ ncurry _ ndip [ like ] _ apply-curry _ spread* ] call ; inline diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 7b50d7c443..5a727d6b3e 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -58,7 +58,7 @@ PRIVATE> (assoc-each) each ; inline : assoc>map ( assoc quot exemplar -- seq ) - [ accumulator [ assoc-each ] dip ] dip like ; inline + [ collector [ assoc-each ] dip ] dip like ; inline : assoc-map-as ( assoc quot exemplar -- newassoc ) [ [ 2array ] compose V{ } assoc>map ] dip assoc-like ; inline diff --git a/core/io/io.factor b/core/io/io.factor index c134ba2108..48d7f413b8 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -113,7 +113,7 @@ PRIVATE> input-stream get swap each-stream-line ; inline : stream-lines ( stream -- seq ) - [ [ ] accumulator [ each-stream-line ] dip { } like ] with-disposal ; + [ [ ] collector [ each-stream-line ] dip { } like ] with-disposal ; : lines ( -- seq ) input-stream get stream-lines ; inline diff --git a/core/make/make-docs.factor b/core/make/make-docs.factor index 881c36e3b6..3366357011 100644 --- a/core/make/make-docs.factor +++ b/core/make/make-docs.factor @@ -37,7 +37,7 @@ $nl { $code "'[ 2 _ + ]" } ; ARTICLE: "namespaces-make" "Making sequences with variables" -"The " { $vocab-link "make" } " vocabulary implements a facility for constructing sequences by holding an accumulator sequence in a variable. Storing the accumulator sequence in a variable rather than the stack may allow code to be written with less stack manipulation." +"The " { $vocab-link "make" } " vocabulary implements a facility for constructing sequences by holding an collector sequence in a variable. Storing the collector sequence in a variable rather than the stack may allow code to be written with less stack manipulation." $nl "Sequence construction is wrapped in a combinator:" { $subsections make } @@ -47,7 +47,7 @@ $nl % # } -"The accumulator sequence can be accessed directly from inside a " { $link make } ":" +"The collector sequence can be accessed directly from inside a " { $link make } ":" { $subsections building } { $example "USING: make math.parser ;" diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 9f570f97d5..819b5b2115 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -993,16 +993,16 @@ HELP: count "50" } ; -HELP: pusher +HELP: selector { $values { "quot" "a predicate quotation" } { "quot" quotation } { "accum" vector } } -{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." } +{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the collector if the test yields true. The collector is left on the stack for convenience." } { $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;" - "10 iota [ even? ] pusher [ each ] dip ." + "10 iota [ even? ] selector [ each ] dip ." "V{ 0 2 4 6 8 }" } -{ $notes "Used to implement the " { $link filter } " word. Compare this word with " { $link accumulator } ", which is an unfiltering version." } ; +{ $notes "Used to implement the " { $link filter } " word. Compare this word with " { $link collector } ", which is an unfiltering version." } ; HELP: trim-head { $values @@ -1199,7 +1199,7 @@ HELP: 2map-reduce "1290" } } ; -HELP: 2pusher +HELP: 2selector { $values { "quot" quotation } { "quot" quotation } { "accum1" vector } { "accum2" vector } } @@ -1224,13 +1224,13 @@ HELP: 2unclip-slice "T{ slice { from 1 } { to 2 } { seq { 1 2 } } }\nT{ slice { from 1 } { to 2 } { seq { 3 4 } } }\n1\n3" } } ; -HELP: accumulator +HELP: collector { $values { "quot" quotation } { "quot'" quotation } { "vec" vector } } { $description "Creates a new quotation that pushes its result to a vector and outputs that vector on the stack." } { $examples { $example "USING: sequences prettyprint kernel math ;" - "{ 1 2 } [ 30 + ] accumulator [ each ] dip ." + "{ 1 2 } [ 30 + ] collector [ each ] dip ." "V{ 31 32 }" } } ; @@ -1680,14 +1680,14 @@ ARTICLE: "sequences-f" "The f object as a sequence" ARTICLE: "sequences-combinator-implementation" "Implementing sequence combinators" "Creating a new sequence unconditionally:" { $subsections - accumulator - accumulator-for + collector + collector-for } "Creating a new sequence conditionally:" { $subsections - pusher - pusher-for - 2pusher + selector + selector-for + 2selector } ; ARTICLE: "sequences" "Sequence operations" diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index b8a8d5f89d..1d9f0e41f9 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -486,14 +486,14 @@ PRIVATE> : push-if ( elt quot accum -- ) [ keep ] dip rot [ push ] [ 2drop ] if ; inline -: pusher-for ( quot exemplar -- quot accum ) +: selector-for ( quot exemplar -- quot accum ) [ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline -: pusher ( quot -- quot accum ) - V{ } pusher-for ; inline +: selector ( quot -- quot accum ) + V{ } selector-for ; inline : filter-as ( seq quot exemplar -- subseq ) - dup [ pusher-for [ each ] dip ] curry dip like ; inline + dup [ selector-for [ each ] dip ] curry dip like ; inline : filter ( seq quot -- subseq ) over filter-as ; inline @@ -501,20 +501,20 @@ PRIVATE> : push-either ( elt quot accum1 accum2 -- ) [ keep swap ] 2dip ? push ; inline -: 2pusher ( quot -- quot accum1 accum2 ) +: 2selector ( quot -- quot accum1 accum2 ) V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline : partition ( seq quot -- trueseq falseseq ) - over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline + over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline -: accumulator-for ( quot exemplar -- quot' vec ) +: collector-for ( quot exemplar -- quot' vec ) [ length ] keep new-resizable [ [ push ] curry compose ] keep ; inline -: accumulator ( quot -- quot' vec ) - V{ } accumulator-for ; inline +: collector ( quot -- quot' vec ) + V{ } collector-for ; inline : produce-as ( pred quot exemplar -- seq ) - dup [ accumulator-for [ while ] dip ] curry dip like ; inline + dup [ collector-for [ while ] dip ] curry dip like ; inline : produce ( pred quot -- seq ) { } produce-as ; inline diff --git a/extra/mongodb/operations/operations.factor b/extra/mongodb/operations/operations.factor index 108f610940..8ecd5df54c 100644 --- a/extra/mongodb/operations/operations.factor +++ b/extra/mongodb/operations/operations.factor @@ -70,7 +70,7 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) read-longlong >>cursor read-int32 >>start# read-int32 [ >>returned# ] keep - [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; + [ H{ } stream>assoc ] collector [ times ] dip >>objects ; : read-header ( message -- message ) read-int32 >>length diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 1a6d9012ce..d6b00d2d04 100644 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -52,7 +52,7 @@ syn keyword factorKeyword or 2bi 2tri while wrapper nip 4dip wrapper? bi* callst syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map assoc assoc-map enum value-at* assoc-map-as >alist assoc-filter-as clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot syn keyword factorKeyword number= if-zero next-power-of-2 each-integer ?1+ fp-special? imaginary-part unless-zero float>bits number? fp-infinity? bignum? fp-snan? denominator fp-bitwise= * + power-of-2? - u>= / >= bitand log2-expects-positive < log2 > integer? number bits>double 2/ zero? (find-integer) bits>float float? shift ratio? even? ratio fp-sign bitnot >fixnum complex? /i /f byte-array>bignum when-zero sgn >bignum next-float u< u> mod recip rational find-last-integer >float (all-integers?) 2^ times integer fixnum? neg fixnum sq bignum (each-integer) bit? fp-qnan? find-integer complex real double>bits bitor rem fp-nan-payload all-integers? real-part log2-expects-positive? prev-float align unordered? float fp-nan? abs bitxor u<= odd? <= /mod rational? >integer real? numerator -syn keyword factorKeyword member-eq? append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as last-index-from reversed index-from cut* pad-tail remove-eq! concat-as but-last snip trim-tail nths nth 2pusher sequence slice? partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length drop-prefix unclip unclip-last-slice iota map-sum bounds-error? sequence-hashcode-step pusher-for accumulate-as map start midpoint@ (accumulate) rest-slice prepend fourth sift accumulate! new-sequence follow map! like first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum suffix! insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? reverse! 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find filter! append-as reduce sequence= halves collapse-slice interleave 2map filter-as binary-reduce slice-error? product bounds-check? bounds-check harvest immutable virtual-exemplar find produce remove pad-head last replicate set-fourth remove-eq shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulator-for accumulate each pusher append! new-resizable cut-slice each-index head-slice* 2reverse-each sequence-hashcode pop set-nth ?nth second join when-empty accumulator immutable-sequence? all? 3append-as virtual-sequence subseq? remove-nth! push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum remove! glue slice-error subseq trim replace-slice push repetition map-index trim-head unclip-last mismatch +syn keyword factorKeyword member-eq? append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as last-index-from reversed index-from cut* pad-tail remove-eq! concat-as but-last snip trim-tail nths nth 2selector sequence slice? partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length drop-prefix unclip unclip-last-slice iota map-sum bounds-error? sequence-hashcode-step selector-for accumulate-as map start midpoint@ (accumulate) rest-slice prepend fourth sift accumulate! new-sequence follow map! like first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum suffix! insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? reverse! 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find filter! append-as reduce sequence= halves collapse-slice interleave 2map filter-as binary-reduce slice-error? product bounds-check? bounds-check harvest immutable virtual-exemplar find produce remove pad-head last replicate set-fourth remove-eq shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? collector-for accumulate each selector append! new-resizable cut-slice each-index head-slice* 2reverse-each sequence-hashcode pop set-nth ?nth second join when-empty collector immutable-sequence? all? 3append-as virtual-sequence subseq? remove-nth! push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum remove! glue slice-error subseq trim replace-slice push repetition map-index trim-head unclip-last mismatch syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc syn keyword factorKeyword 2array 3array pair >array 1array 4array pair? array resize-array array? syn keyword factorKeyword +character+ bad-seek-type? readln each-morsel stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents stream-tell tell-output bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* tell-input each-block output-stream stream-read-partial each-stream-block each-stream-line From 760746e2ff87931858b38d47143db620cc561e25 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 15:01:38 -0600 Subject: [PATCH 37/72] Fix using --- basis/io/mmap/unix/unix.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 559417d2b9..f426201b06 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors destructors io.backend.unix io.mmap -io.mmap.private kernel locals math.bitwise system unix ; +io.mmap.private kernel locals math.bitwise system unix unix.ffi ; IN: io.mmap.unix :: mmap-open ( path length prot flags open-mode -- alien fd ) From 1519e0ba691e194f2d04fd5ed3d3f8c87914e5cb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 15:04:13 -0600 Subject: [PATCH 38/72] move (accumulate) to sequences.private --- core/sequences/sequences.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 1d9f0e41f9..b7c6708044 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -403,6 +403,9 @@ PRIVATE> [ 2drop f f ] if ; inline +: (accumulate) ( seq identity quot -- seq identity quot ) + [ swap ] dip [ curry keep ] curry ; inline + PRIVATE> : each ( seq quot -- ) @@ -429,9 +432,6 @@ PRIVATE> : map! ( seq quot -- seq ) over [ map-into ] keep ; inline -: (accumulate) ( seq identity quot -- seq identity quot ) - [ swap ] dip [ curry keep ] curry ; inline - : accumulate-as ( seq identity quot exemplar -- final newseq ) [ (accumulate) ] dip map-as ; inline From afdb7f6329625bdbca0880a95510861564700488 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 15:07:01 -0600 Subject: [PATCH 39/72] remove a stray character --- basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor index e2f2e5d41a..4b459e90fb 100644 --- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor @@ -1,4 +1,4 @@ -!r Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs bit-arrays bit-sets fry hashtables hints kernel locals math namespaces sequences sets From a16d8db145820c414ef453460e18e89f52b1189f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 16:30:22 -0600 Subject: [PATCH 40/72] move sequence-hashcode-step to private --- core/sequences/sequences.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index b7c6708044..d3a7aba1c3 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -603,12 +603,16 @@ ERROR: assert-sequence got expected ; : assert-sequence= ( a b -- ) 2dup sequence= [ 2drop ] [ assert-sequence ] if ; +fixnum swap [ [ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi fixnum+fast fixnum+fast ] keep fixnum-bitxor ; inline +PRIVATE> + : sequence-hashcode ( n seq -- x ) [ 0 ] 2dip [ hashcode* sequence-hashcode-step ] with each ; inline From 4857c737d3ff7621788d3bde23b1ce7c283d2a80 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 16:55:05 -0600 Subject: [PATCH 41/72] Fix getgrent call in unix.groups --- basis/unix/groups/groups.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index a9b80002a8..7c2da50c9e 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -83,7 +83,7 @@ M: integer user-groups ( id -- seq ) user-name (user-groups) ; : all-groups ( -- seq ) - [ [ unix.ffi:getgrent ] unix-system-call dup ] [ \ unix.ffi:group memory>struct group-struct>group ] produce nip ; + [ unix.ffi:getgrent dup ] [ \ unix.ffi:group memory>struct group-struct>group ] produce nip ; : ( -- assoc ) all-groups [ [ id>> ] keep ] H{ } map>assoc ; From f0f3252113dd5f9f5e0b3a6b4fcad46573969035 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 22 Jan 2010 15:06:04 -0800 Subject: [PATCH 42/72] unicode.case: rename title-word to capitalize and make it public --- basis/unicode/case/case.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 79db087220..9726b6dd78 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -109,13 +109,13 @@ HINTS: >upper string ; lt? [ lithuanian>upper ] when [ title>> ] [ ch>title ] map-case ; inline -: title-word ( string -- title ) - unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline - PRIVATE> +: capitalize ( string -- title ) + unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline + : >title ( string -- title ) - final-sigma >words [ title-word ] map concat ; + final-sigma >words [ capitalize ] map concat ; HINTS: >title string ; From 2bf53dde61da5aebd1480d3032b3d32e0f9031ac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 17:10:32 -0600 Subject: [PATCH 43/72] Fix netbsd load error --- basis/unix/ffi/bsd/netbsd/netbsd.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/unix/ffi/bsd/netbsd/netbsd.factor b/basis/unix/ffi/bsd/netbsd/netbsd.factor index e519652421..d755caf874 100644 --- a/basis/unix/ffi/bsd/netbsd/netbsd.factor +++ b/basis/unix/ffi/bsd/netbsd/netbsd.factor @@ -1,5 +1,5 @@ USING: alien.syntax alien.c-types math vocabs.loader -classes.struct unix.types ; +classes.struct unix.types unix.time ; IN: unix.ffi CONSTANT: FD_SETSIZE 256 @@ -127,6 +127,8 @@ CONSTANT: _UTX_LINESIZE 32 CONSTANT: _UTX_IDSIZE 4 CONSTANT: _UTX_HOSTSIZE 256 +<< + CONSTANT: _SS_MAXSIZE 128 : _SS_ALIGNSIZE ( -- n ) @@ -138,6 +140,8 @@ CONSTANT: _SS_MAXSIZE 128 : _SS_PAD2SIZE ( -- n ) _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline +>> + STRUCT: sockaddr_storage { ss_len __uint8_t } { ss_family sa_family_t } From cc068b4f72962fad111f9d857dfc353c4da24e30 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Jan 2010 19:05:17 -0600 Subject: [PATCH 44/72] getgrent doesn't need unix-system-call --- basis/unix/groups/groups.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index a9b80002a8..7c2da50c9e 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -83,7 +83,7 @@ M: integer user-groups ( id -- seq ) user-name (user-groups) ; : all-groups ( -- seq ) - [ [ unix.ffi:getgrent ] unix-system-call dup ] [ \ unix.ffi:group memory>struct group-struct>group ] produce nip ; + [ unix.ffi:getgrent dup ] [ \ unix.ffi:group memory>struct group-struct>group ] produce nip ; : ( -- assoc ) all-groups [ [ id>> ] keep ] H{ } map>assoc ; From 7d0c67adf034cc0abe82bf604a88360194d694e0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 22 Jan 2010 18:40:00 -0800 Subject: [PATCH 45/72] remove redundant text from docs for locals docs --- basis/locals/locals-docs.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index f44b5177e1..4c4b4ad485 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -4,7 +4,7 @@ IN: locals HELP: [| { $syntax "[| bindings... | body... ]" } -{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack values and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." } +{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." } { $examples "See " { $link "locals-examples" } "." } ; HELP: [let @@ -20,7 +20,7 @@ $nl { $code ":> c :> b :> a" } { $code ":> ( a b c )" } $nl -"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information." } { $notes "This syntax can only be used inside a lexical scope established by a " { $link POSTPONE: :: } " definition, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: [| } " quotation. Normal quotations have their own lexical scope only if they are inside an outer scope. Definition forms such as " { $link POSTPONE: : } " do not establish a lexical scope by themselves unless documented otherwise, nor is there a lexical scope available at the top level of source files or in the listener. " { $link POSTPONE: [let } " can be used to create a lexical scope where one is not otherwise available." } { $examples "See " { $link "locals-examples" } "." } ; @@ -31,7 +31,7 @@ HELP: :: { $syntax ":: word ( vars... -- outputs... ) body... ;" } { $description "Defines a word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope." $nl -"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." } { $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: : } " definitions." } { $examples "See " { $link "locals-examples" } "." } ; @@ -41,7 +41,7 @@ HELP: MACRO:: { $syntax "MACRO:: word ( vars... -- outputs... ) body... ;" } { $description "Defines a macro with named inputs. The macro binds its input variables to lexical variables from left to right, then executes the body with those bindings in scope." $nl -"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." } { $notes "The expansion of a macro cannot reference lexical variables bound in the outer scope. There are also limitations on passing arguments involving lexical variables into macros. See " { $link "locals-limitations" } " for details." } { $examples "See " { $link "locals-examples" } "." } ; @@ -51,7 +51,7 @@ HELP: MEMO:: { $syntax "MEMO:: word ( vars... -- outputs... ) body... ;" } { $description "Defines a memoized word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope." $nl -"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." } { $examples "See " { $link "locals-examples" } "." } ; { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words @@ -60,7 +60,7 @@ HELP: M:: { $syntax "M:: class generic ( vars... -- outputs... ) body... ;" } { $description "Defines a new method on " { $snippet "generic" } " for " { $snippet "class" } " with named inputs. The method binds its input values to lexical variables from left to right, then executes the body with those bindings in scope." $nl -"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." } +"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." } { $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: M: } " definitions." } { $examples "See " { $link "locals-examples" } "." } ; From 7c40fc1a36066948b605988ff718bff99db2cc46 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 23 Jan 2010 09:07:35 -0600 Subject: [PATCH 46/72] unix-system-call io-error -> unix-system-call drop make unix.ffi, unix.ffi.linux unportable fix spacing in io.cpp before refactoring --- basis/io/backend/unix/unix.factor | 6 +++--- basis/io/directories/unix/unix.factor | 12 +++++------ basis/io/files/info/unix/unix.factor | 8 +++---- basis/io/files/links/unix/unix.factor | 4 ++-- basis/io/files/unix/unix.factor | 2 +- basis/io/sockets/unix/unix.factor | 6 +++--- basis/unix/ffi/linux/tags.txt | 1 + basis/unix/ffi/tags.txt | 1 + basis/unix/groups/groups.factor | 10 ++++----- basis/unix/users/users.factor | 4 ++-- vm/io.cpp | 30 +++++++++++++-------------- 11 files changed, 43 insertions(+), 41 deletions(-) create mode 100644 basis/unix/ffi/linux/tags.txt create mode 100644 basis/unix/ffi/tags.txt diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 6412132725..1797edccf6 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -17,8 +17,8 @@ TUPLE: fd < disposable fd ; : init-fd ( fd -- fd ) [ |dispose - dup fd>> F_SETFL O_NONBLOCK [ fcntl ] unix-system-call io-error - dup fd>> F_SETFD FD_CLOEXEC [ fcntl ] unix-system-call io-error + dup fd>> F_SETFL O_NONBLOCK [ fcntl ] unix-system-call drop + dup fd>> F_SETFD FD_CLOEXEC [ fcntl ] unix-system-call drop ] with-destructors ; : ( n -- fd ) @@ -59,7 +59,7 @@ M: unix seek-handle ( n seek-type handle -- ) { io:seek-end [ SEEK_END ] } [ io:bad-seek-type ] } case - [ fd>> swap ] dip [ lseek ] unix-system-call io-error ; + [ fd>> swap ] dip [ lseek ] unix-system-call drop ; SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index a62a431de8..77d7f2d1b2 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -17,29 +17,29 @@ M: unix touch-file ( path -- ) ] if ; M: unix move-file ( from to -- ) - [ normalize-path ] bi@ [ rename ] unix-system-call io-error ; + [ normalize-path ] bi@ [ rename ] unix-system-call drop ; M: unix delete-file ( path -- ) normalize-path unlink-file ; M: unix make-directory ( path -- ) - normalize-path OCT: 777 [ mkdir ] unix-system-call io-error ; + normalize-path OCT: 777 [ mkdir ] unix-system-call drop ; M: unix delete-directory ( path -- ) - normalize-path [ rmdir ] unix-system-call io-error ; + normalize-path [ rmdir ] unix-system-call drop ; M: unix copy-file ( from to -- ) [ normalize-path ] bi@ call-next-method ; : with-unix-directory ( path quot -- ) - [ [ opendir ] unix-system-call dup [ (io-error) ] unless ] dip - dupd curry swap '[ _ [ closedir ] unix-system-call io-error ] [ ] cleanup ; inline + [ opendir dup [ (io-error) ] unless ] dip + dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline HOOK: find-next-file os ( DIR* -- byte-array ) M: unix find-next-file ( DIR* -- byte-array ) dirent f - [ [ readdir_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep + [ readdir_r 0 = [ (io-error) ] unless ] 2keep *void* [ drop f ] unless ; : dirent-type>file-type ( ch -- type ) diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index ff604759c1..3b85467964 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -109,7 +109,7 @@ M: unix stat>type ( stat -- type ) : chmod-set-bit ( path mask ? -- ) [ dup stat-mode ] 2dip - [ bitor ] [ unmask ] if [ chmod ] unix-system-call io-error ; + [ bitor ] [ unmask ] if [ chmod ] unix-system-call drop ; GENERIC# file-mode? 1 ( obj mask -- ? ) @@ -174,7 +174,7 @@ CONSTANT: ALL-EXECUTE OCT: 0000111 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ; : set-file-permissions ( path n -- ) - [ normalize-path ] dip [ chmod ] unix-system-call io-error ; + [ normalize-path ] dip [ chmod ] unix-system-call drop ; : file-permissions ( path -- n ) normalize-path file-info permissions>> ; @@ -202,7 +202,7 @@ PRIVATE> : set-file-times ( path timestamps -- ) #! set access, write [ normalize-path ] dip - timestamps>byte-array [ utimes ] unix-system-call io-error ; + timestamps>byte-array [ utimes ] unix-system-call drop ; : set-file-access-time ( path timestamp -- ) f 2array set-file-times ; @@ -212,7 +212,7 @@ PRIVATE> : set-file-ids ( path uid gid -- ) [ normalize-path ] 2dip [ -1 or ] bi@ - [ chown ] unix-system-call io-error ; + [ chown ] unix-system-call drop ; GENERIC: set-file-user ( path string/id -- ) diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index f97478c332..3f67bb453f 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -5,10 +5,10 @@ sequences system unix unix.ffi ; IN: io.files.links.unix M: unix make-link ( path1 path2 -- ) - normalize-path [ symlink ] unix-system-call io-error ; + normalize-path [ symlink ] unix-system-call drop ; M: unix make-hard-link ( path1 path2 -- ) - normalize-path [ link ] unix-system-call io-error ; + normalize-path [ link ] unix-system-call drop ; M: unix read-link ( path -- path' ) normalize-path read-symbolic-link ; diff --git a/basis/io/files/unix/unix.factor b/basis/io/files/unix/unix.factor index 7293cf67fa..bf0a21f997 100644 --- a/basis/io/files/unix/unix.factor +++ b/basis/io/files/unix/unix.factor @@ -34,7 +34,7 @@ M: unix (file-writer) ( path -- stream ) : open-append ( path -- fd ) [ append-flags file-mode open-file |dispose - dup 0 SEEK_END [ lseek ] unix-system-call io-error + dup 0 SEEK_END [ lseek ] unix-system-call drop ] with-destructors ; M: unix (file-appender) ( path -- stream ) diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index fcf84f7925..cc0740500a 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -77,7 +77,7 @@ M:: object establish-connection ( client-out remote -- ) : ?bind-client ( socket -- ) bind-local-address get [ [ fd>> ] dip make-sockaddr/size - [ bind ] unix-system-call io-error + [ bind ] unix-system-call drop ] [ drop ] if* ; inline @@ -93,12 +93,12 @@ M: object ((client)) ( addrspec -- fd ) : server-socket-fd ( addrspec type -- fd ) [ dup protocol-family ] dip socket-fd [ init-server-socket ] keep - [ handle-fd swap make-sockaddr/size [ bind ] unix-system-call io-error ] keep ; + [ handle-fd swap make-sockaddr/size [ bind ] unix-system-call drop ] keep ; M: object (server) ( addrspec -- handle ) [ SOCK_STREAM server-socket-fd - dup handle-fd 128 listen io-error + dup handle-fd 128 [ listen ] unix-system-call drop ] with-destructors ; : do-accept ( server addrspec -- fd sockaddr ) diff --git a/basis/unix/ffi/linux/tags.txt b/basis/unix/ffi/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/ffi/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/ffi/tags.txt b/basis/unix/ffi/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/ffi/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 7c2da50c9e..c34affb9c3 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -31,12 +31,12 @@ GENERIC: group-struct ( obj -- group/f ) M: integer group-struct ( id -- group/f ) (group-struct) - [ [ unix.ffi:getgrgid_r ] unix-system-call io-error ] keep + [ [ unix.ffi:getgrgid_r ] unix-system-call drop ] keep check-group-struct ; M: string group-struct ( string -- group/f ) (group-struct) - [ [ unix.ffi:getgrnam_r ] unix-system-call io-error ] keep + [ [ unix.ffi:getgrnam_r ] unix-system-call drop ] keep check-group-struct ; : group-struct>group ( group-struct -- group ) @@ -69,7 +69,7 @@ PRIVATE> : (user-groups) ( string -- seq ) #! first group is -1337, legacy unix code -1337 unix.ffi:NGROUPS_MAX [ 4 * ] keep - [ [ unix.ffi:getgrouplist ] unix-system-call io-error ] 2keep + [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep [ 4 tail-slice ] [ *int 1 - ] bi* >groups ; PRIVATE> @@ -115,10 +115,10 @@ GENERIC: set-effective-group ( obj -- ) diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index b279069c59..adf7f5ce4f 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -93,10 +93,10 @@ GENERIC: set-effective-user ( string/id -- ) diff --git a/vm/io.cpp b/vm/io.cpp index 9722676f31..a3283b84ac 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -33,35 +33,35 @@ void factor_vm::io_error() size_t safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream) { - size_t items_read = 0; + size_t items_read = 0; - do { - items_read += fread((void*)((int*)ptr+items_read*size),size,nitems-items_read,stream); - } while(items_read != nitems && errno == EINTR); + do { + items_read += fread((void*)((int*)ptr+items_read*size),size,nitems-items_read,stream); + } while(items_read != nitems && errno == EINTR); - return items_read; + return items_read; } size_t safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream) { - size_t items_written = 0; + size_t items_written = 0; - do { - items_written += fwrite((void*)((int*)ptr+items_written*size),size,nitems-items_written,stream); - } while(items_written != nitems && errno == EINTR); + do { + items_written += fwrite((void*)((int*)ptr+items_written*size),size,nitems-items_written,stream); + } while(items_written != nitems && errno == EINTR); - return items_written; + return items_written; } int safe_fclose(FILE *stream) { - int ret = 0; + int ret = 0; - do { - ret = fclose(stream); - } while(ret != 0 && errno == EINTR); + do { + ret = fclose(stream); + } while(ret != 0 && errno == EINTR); - return ret; + return ret; } void factor_vm::primitive_fopen() From 1a5768030be53201cdfa04c702711344f0ff499f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 23 Jan 2010 10:03:02 -0600 Subject: [PATCH 47/72] Make unix.debugger unportable --- basis/unix/debugger/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/unix/debugger/tags.txt diff --git a/basis/unix/debugger/tags.txt b/basis/unix/debugger/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/debugger/tags.txt @@ -0,0 +1 @@ +unportable From c50682c6f0b1d2722116711ec78184753dd51805 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 23 Jan 2010 10:12:25 -0600 Subject: [PATCH 48/72] make unix.utilities unportable --- basis/unix/utilities/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/unix/utilities/tags.txt diff --git a/basis/unix/utilities/tags.txt b/basis/unix/utilities/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/utilities/tags.txt @@ -0,0 +1 @@ +unportable From 6ec4f4ef8bc9eb5af26c9d1ecb837d098cb09759 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 24 Jan 2010 10:05:56 -0800 Subject: [PATCH 49/72] more fussing over locals docs grammar --- basis/locals/locals-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 4c4b4ad485..d78905c0d7 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -209,7 +209,7 @@ $nl ARTICLE: "locals-mutable" "Mutable lexical variables" "When a lexical variable is bound using " { $link POSTPONE: :> } ", " { $link POSTPONE: :: } ", or " { $link POSTPONE: [| } ", the variable may be made mutable by suffixing its name with an exclamation point (" { $snippet "!" } "). A mutable variable's value is read by giving its name without the exclamation point as usual. To write to the variable, use its name with the " { $snippet "!" } " suffix." $nl -"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it." +"Mutable bindings are implemented in a manner similar to that taken by the ML language. Each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it." $nl "Writing to mutable variables from outer lexical scopes is fully supported and has full closure semantics. See " { $link "locals-examples" } " for examples of mutable lexical variables in action." ; From a751ecd8b7a5f2a26708c57afc10b238f0a9dc11 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 24 Jan 2010 10:07:14 -0800 Subject: [PATCH 50/72] audio.engine: let audio generators determine their own buffer size --- extra/audio/engine/engine.factor | 11 ++++------- extra/audio/engine/test/test.factor | 6 ++++-- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index 3bc81cd681..23aeb891b4 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -56,7 +56,7 @@ M: audio-listener audio-gain gain>> ; inline M: audio-listener audio-velocity velocity>> ; inline M: audio-listener audio-orientation orientation>> ; inline -GENERIC# generate-audio 1 ( generator buffer-size -- c-ptr size ) +GENERIC: generate-audio ( generator -- c-ptr size ) GENERIC: generator-audio-format ( generator -- channels sample-bits sample-rate ) TUPLE: audio-engine < disposable @@ -79,7 +79,6 @@ TUPLE: static-audio-clip < audio-clip TUPLE: streaming-audio-clip < audio-clip generator - { buffer-size integer } { channels integer } { sample-bits integer } { sample-rate integer } @@ -151,8 +150,7 @@ ERROR: audio-context-not-available device-name ; :: queue-clip-buffer ( audio-clip al-buffer -- ) audio-clip al-source>> :> al-source audio-clip generator>> :> generator - audio-clip buffer-size>> :> buffer-size - generator buffer-size generate-audio :> ( data size ) + generator generate-audio :> ( data size ) data [ al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData @@ -267,7 +265,7 @@ M: audio-engine dispose* clip ] [ f ] if ; -:: ( audio-engine source generator buffer-size buffer-count -- audio-clip/f ) +:: ( audio-engine source generator buffer-count -- audio-clip/f ) audio-engine get-available-source :> al-source al-source [ @@ -279,7 +277,6 @@ M: audio-engine dispose* source >>source al-source >>al-source generator >>generator - buffer-size >>buffer-size channels >>channels sample-bits >>sample-bits sample-rate >>sample-rate @@ -313,7 +310,7 @@ M: streaming-audio-clip dispose* : play-static-audio-clip ( audio-engine source audio loop? -- audio-clip/f ) dup [ play-clip ] when* ; -: play-streaming-audio-clip ( audio-engine source generator buffer-size buffer-count -- audio-clip/f ) +: play-streaming-audio-clip ( audio-engine source generator buffer-count -- audio-clip/f ) dup [ play-clip ] when* ; : pause-clip ( audio-clip -- ) diff --git a/extra/audio/engine/test/test.factor b/extra/audio/engine/test/test.factor index 46c45f84b1..3107b96e7a 100644 --- a/extra/audio/engine/test/test.factor +++ b/extra/audio/engine/test/test.factor @@ -11,7 +11,9 @@ TUPLE: noise-generator ; M: noise-generator generator-audio-format drop 1 16 8000 ; M: noise-generator generate-audio - nip [ -1 shift [ -4096 4096 [a,b] random ] short-array{ } replicate-as ] keep ; + drop + 4096 [ -4096 4096 [a,b] random ] short-array{ } replicate-as + 8192 ; :: audio-engine-test ( -- ) "vocab:audio/engine/test/loop.aiff" read-audio :> loop-sound @@ -22,7 +24,7 @@ M: noise-generator generate-audio engine T{ audio-source f { 1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } loop-sound t play-static-audio-clip :> loop-clip - engine T{ audio-source f { -1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } noise-generator new 8192 2 + engine T{ audio-source f { -1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } noise-generator new 2 play-streaming-audio-clip :> noise-clip [ From 1ca0b142353b1ad428863065f26a1548c747a46a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 24 Jan 2010 10:08:39 -0800 Subject: [PATCH 51/72] =?UTF-8?q?steal=20chris=20double's=20ogg.player=20c?= =?UTF-8?q?ode=20and=20turn=20it=20into=20an=20audio.engine=20compatible?= =?UTF-8?q?=20vorbis=20streamer.=20phase=201=E2=80=94read=20headers=20and?= =?UTF-8?q?=20determine=20stream=20audio=20format?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- extra/audio/vorbis/vorbis.factor | 182 +++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 extra/audio/vorbis/vorbis.factor diff --git a/extra/audio/vorbis/vorbis.factor b/extra/audio/vorbis/vorbis.factor new file mode 100644 index 0000000000..0c77698db5 --- /dev/null +++ b/extra/audio/vorbis/vorbis.factor @@ -0,0 +1,182 @@ +! (c)2010 Chris Double, Joe Groff bsd license +USING: accessors alien.c-types audio.engine byte-arrays classes.struct +combinators destructors fry gpu.buffers io kernel libc make +math math.order math.parser ogg ogg.vorbis sequences ; +IN: audio.vorbis + +TUPLE: vorbis-stream < disposable + stream + { packet ogg-packet } + { sync-state ogg-sync-state } + { page ogg-page } + { stream-state ogg-stream-state } + { info vorbis-info } + { dsp-state vorbis-dsp-state } + { block vorbis-block } + { comment vorbis-comment } + { temp-state ogg-stream-state } + { #vorbis-headers integer initial: 0 } ; + +CONSTANT: stream-buffer-size 4096 + +ERROR: ogg-error code ; +ERROR: vorbis-error code ; +ERROR: no-vorbis-in-ogg ; + +> ogg_sync_init drop ] + [ info>> vorbis_info_init ] + [ comment>> vorbis_comment_init ] tri ; + +: sync-buffer ( vorbis-stream -- buffer size ) + sync-state>> stream-buffer-size ogg_sync_buffer + stream-buffer-size ; inline + +: read-bytes-into ( dest size stream -- len ) + #! Read the given number of bytes from a stream + #! and store them in the destination byte array. + stream-read >byte-array dup length [ memcpy ] keep ; + +: stream-into-buffer ( buffer size vorbis-stream -- len ) + stream>> read-bytes-into ; inline + +: ?ogg-error ( n -- ) + dup 0 < [ ogg-error ] [ drop ] if ; inline + +: confirm-buffer ( len vorbis-stream -- ? ) + '[ _ sync-state>> swap ogg_sync_wrote ?ogg-error ] keep zero? not ; inline + +: buffer-data-from-stream ( vorbis-stream -- ? ) + [ sync-buffer ] [ stream-into-buffer ] [ confirm-buffer ] tri ; inline + +: queue-page ( vorbis-stream -- ) + [ stream-state>> ] [ page>> ] bi ogg_stream_pagein drop ; inline + +: retrieve-page ( vorbis-stream -- ? ) + [ sync-state>> ] [ page>> ] bi ogg_sync_pageout 0 > ; inline + +: standard-initial-header? ( vorbis-stream -- bool ) + page>> ogg_page_bos zero? not ; inline + +: ogg-stream-init ( vorbis-stream -- state ) + [ temp-state>> dup ] + [ page>> ogg_page_serialno ogg_stream_init ?ogg-error ] bi ; inline + +: ogg-stream-pagein ( state vorbis-stream -- ) + page>> ogg_stream_pagein drop ; inline + +: ogg-stream-packetout ( state vorbis-stream -- ) + packet>> ogg_stream_packetout drop ; inline + +: decode-packet ( vorbis-stream -- state ) + [ ogg-stream-init ] keep + [ ogg-stream-pagein ] [ ogg-stream-packetout ] [ drop ] 2tri ; inline + +: vorbis-header? ( vorbis-stream -- ? ) + [ info>> ] [ comment>> ] [ packet>> ] tri vorbis_synthesis_headerin 0 >= ; inline + +: is-initial-vorbis-packet? ( vorbis-stream -- ? ) + dup #vorbis-headers>> zero? [ vorbis-header? ] [ drop f ] if ; inline + +: save-initial-vorbis-header ( state vorbis-stream -- ) + [ stream-state>> swap dup byte-length memcpy ] + [ 1 >>#vorbis-headers drop ] bi ; inline + +: drop-initial-other-header ( state vorbis-stream -- ) + swap ogg_stream_clear 2drop ; inline + +: process-initial-header ( vorbis-stream -- ? ) + dup standard-initial-header? [ + [ decode-packet ] keep + dup is-initial-vorbis-packet? + [ save-initial-vorbis-header ] + [ drop-initial-other-header ] if + t + ] [ drop f ] if ; + +: parse-initial-headers ( vorbis-stream -- ) + dup retrieve-page + [ dup process-initial-header [ parse-initial-headers ] [ queue-page ] if ] + [ dup buffer-data-from-stream [ parse-initial-headers ] [ drop ] if ] if ; + +: have-required-vorbis-headers? ( vorbis-stream -- ? ) + #vorbis-headers>> 1 2 between? not ; inline + +: ?vorbis-error ( code -- ) + [ vorbis-error ] unless-zero ; inline + +: get-remaining-vorbis-header-packet ( player -- ? ) + [ stream-state>> ] [ packet>> ] bi ogg_stream_packetout { + { [ dup 0 < ] [ vorbis-error ] } + { [ dup zero? ] [ drop f ] } + [ drop t ] + } cond ; + +: decode-remaining-vorbis-header-packet ( vorbis-stream -- ) + [ info>> ] [ comment>> ] [ packet>> ] tri vorbis_synthesis_headerin ?vorbis-error ; + +: parse-remaining-vorbis-headers ( vorbis-stream -- ) + dup have-required-vorbis-headers? not [ + dup get-remaining-vorbis-header-packet [ + [ decode-remaining-vorbis-header-packet ] + [ [ 1 + ] change-#vorbis-headers drop ] + [ parse-remaining-vorbis-headers ] tri + ] [ drop ] if + ] [ drop ] if ; + +: parse-remaining-headers ( vorbis-stream -- ) + dup have-required-vorbis-headers? not [ + [ parse-remaining-vorbis-headers ] + [ dup retrieve-page [ queue-page ] [ buffer-data-from-stream drop ] if ] + [ parse-remaining-headers ] tri + ] [ drop ] if ; + +: init-vorbis-codec ( vorbis-stream -- ) + [ [ dsp-state>> ] [ info>> ] bi vorbis_synthesis_init drop ] + [ [ dsp-state>> ] [ block>> ] bi vorbis_block_init drop ] bi ; + +: initialize-decoder ( vorbis-stream -- ) + dup #vorbis-headers>> zero? + [ no-vorbis-in-ogg ] + [ init-vorbis-codec ] if ; +PRIVATE> + +: ( stream -- vorbis-stream ) + [ + vorbis-stream new-disposable + swap >>stream + ogg-packet malloc-struct |free >>packet + ogg-sync-state malloc-struct |free >>sync-state + ogg-page malloc-struct |free >>page + ogg-stream-state malloc-struct |free >>stream-state + vorbis-info malloc-struct |free >>info + vorbis-dsp-state malloc-struct |free >>dsp-state + vorbis-block malloc-struct |free >>block + vorbis-comment malloc-struct |free >>comment + ogg-stream-state malloc-struct |free >>temp-state + dup { + [ init-vorbis ] + [ parse-initial-headers ] + [ parse-remaining-headers ] + [ initialize-decoder ] + } cleave + ] with-destructors ; + +M: vorbis-stream dispose* + { + [ temp-state>> [ free ] when* ] + [ comment>> [ free ] when* ] + [ block>> [ free ] when* ] + [ dsp-state>> [ free ] when* ] + [ info>> [ free ] when* ] + [ stream-state>> [ free ] when* ] + [ page>> [ free ] when* ] + [ sync-state>> [ free ] when* ] + [ packet>> [ free ] when* ] + } cleave ; + +M: vorbis-stream generator-audio-format + [ info>> channels>> ] [ drop 16 ] [ info>> rate>> ] tri ; +M: vorbis-stream generate-audio + drop f f ; From 91e014ef960cec59d7e6c4234949ae4a69690ffb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 24 Jan 2010 12:44:01 -0800 Subject: [PATCH 52/72] audio.engine: dispose generator for streaming-audio-clip when it finishes --- extra/audio/engine/engine.factor | 5 +++-- extra/audio/engine/test/test.factor | 4 +++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index 23aeb891b4..b618c4b608 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -285,7 +285,7 @@ M: audio-engine dispose* al-buffers [ clip swap queue-clip-buffer ] each clip audio-engine clips>> push clip - ] [ f ] if ; + ] [ generator dispose f ] if ; M: audio-clip dispose* [ dup audio-engine>> clips>> remove! drop ] @@ -297,7 +297,8 @@ M: static-audio-clip dispose* M: streaming-audio-clip dispose* [ call-next-method ] - [ al-buffers>> [ length ] keep alDeleteBuffers ] bi ; + [ generator>> dispose ] + [ al-buffers>> [ length ] keep alDeleteBuffers ] tri ; : play-clip ( audio-clip -- ) [ update-source ] diff --git a/extra/audio/engine/test/test.factor b/extra/audio/engine/test/test.factor index 3107b96e7a..bbc6c339e9 100644 --- a/extra/audio/engine/test/test.factor +++ b/extra/audio/engine/test/test.factor @@ -14,12 +14,14 @@ M: noise-generator generate-audio drop 4096 [ -4096 4096 [a,b] random ] short-array{ } replicate-as 8192 ; +M: noise-generator dispose + drop ; :: audio-engine-test ( -- ) "vocab:audio/engine/test/loop.aiff" read-audio :> loop-sound "vocab:audio/engine/test/once.wav" read-audio :> once-sound 0 :> i! - :> engine + f 4 :> engine engine start-audio* engine T{ audio-source f { 1.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } loop-sound t From a7bb13348d8d4a4eccc10bb2cf39806afdc147d6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 24 Jan 2010 12:47:10 -0800 Subject: [PATCH 53/72] =?UTF-8?q?audio.vorbis=20phase=202=E2=80=94actually?= =?UTF-8?q?=20decode=20and=20supply=20audio?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- extra/audio/vorbis/vorbis.factor | 62 ++++++++++++++++++++++++++++---- 1 file changed, 55 insertions(+), 7 deletions(-) diff --git a/extra/audio/vorbis/vorbis.factor b/extra/audio/vorbis/vorbis.factor index 0c77698db5..ca712b8359 100644 --- a/extra/audio/vorbis/vorbis.factor +++ b/extra/audio/vorbis/vorbis.factor @@ -1,7 +1,11 @@ -! (c)2010 Chris Double, Joe Groff bsd license +! (c)2007, 2010 Chris Double, Joe Groff bsd license USING: accessors alien.c-types audio.engine byte-arrays classes.struct -combinators destructors fry gpu.buffers io kernel libc make -math math.order math.parser ogg ogg.vorbis sequences ; +combinators destructors fry gpu.buffers io io.files io.encodings.binary +kernel libc locals make math math.order math.parser ogg ogg.vorbis +sequences specialized-arrays specialized-vectors ; +FROM: alien.c-types => float short void* ; +SPECIALIZED-ARRAYS: float void* ; +SPECIALIZED-VECTOR: short IN: audio.vorbis TUPLE: vorbis-stream < disposable @@ -15,7 +19,8 @@ TUPLE: vorbis-stream < disposable { block vorbis-block } { comment vorbis-comment } { temp-state ogg-stream-state } - { #vorbis-headers integer initial: 0 } ; + { #vorbis-headers integer initial: 0 } + { stream-eof? boolean } ; CONSTANT: stream-buffer-size 4096 @@ -56,6 +61,9 @@ ERROR: no-vorbis-in-ogg ; : retrieve-page ( vorbis-stream -- ? ) [ sync-state>> ] [ page>> ] bi ogg_sync_pageout 0 > ; inline +: sync-pages ( vorbis-stream -- ) + dup retrieve-page [ [ queue-page ] [ sync-pages ] bi ] [ drop ] if ; + : standard-initial-header? ( vorbis-stream -- bool ) page>> ogg_page_bos zero? not ; inline @@ -140,6 +148,41 @@ ERROR: no-vorbis-in-ogg ; dup #vorbis-headers>> zero? [ no-vorbis-in-ogg ] [ init-vorbis-codec ] if ; + +: get-pending-decoded-audio ( vorbis-stream -- pcm len ) + dsp-state>> f [ vorbis_synthesis_pcmout ] keep *void* swap ; + +:: make-pcm-buffer ( vorbis-stream pcm len -- short-array ) + vorbis-stream info>> channels>> :> #channels + pcm #channels :> channel*s + #channels len * :> output + + len iota [| sample | + #channels iota [| channel | + channel channel*s nth len :> samples + sample samples nth + -32767.0 * >integer -32767 32767 clamp + output push + ] each + ] each + output >short-array ; inline + +: read-samples ( vorbis-stream pcm len -- ) + [ dsp-state>> ] [ drop ] [ ] tri* vorbis_synthesis_read drop ; inline + +: queue-audio ( vorbis-stream -- ? ) + dup [ stream-state>> ] [ packet>> ] bi ogg_stream_packetout 0 > [ + dup [ block>> ] [ packet>> ] bi vorbis_synthesis 0 = [ + [ dsp-state>> ] [ block>> ] bi vorbis_synthesis_blockin drop + ] [ drop ] if t + ] [ drop f ] if ; + +: decode-audio ( vorbis-stream -- short-array/f length/f ) + dup get-pending-decoded-audio dup 0 > [ + [ make-pcm-buffer dup byte-length ] [ read-samples ] 3bi + ] [ + 2drop dup queue-audio [ decode-audio ] [ drop f f ] if + ] if ; PRIVATE> : ( stream -- vorbis-stream ) @@ -163,13 +206,16 @@ PRIVATE> } cleave ] with-destructors ; +: read-vorbis-stream ( filename -- vorbis-stream ) + binary ; inline + M: vorbis-stream dispose* { [ temp-state>> [ free ] when* ] - [ comment>> [ free ] when* ] + [ comment>> [ [ vorbis_comment_clear ] [ free ] bi ] when* ] [ block>> [ free ] when* ] [ dsp-state>> [ free ] when* ] - [ info>> [ free ] when* ] + [ info>> [ [ vorbis_info_clear ] [ free ] bi ] when* ] [ stream-state>> [ free ] when* ] [ page>> [ free ] when* ] [ sync-state>> [ free ] when* ] @@ -179,4 +225,6 @@ M: vorbis-stream dispose* M: vorbis-stream generator-audio-format [ info>> channels>> ] [ drop 16 ] [ info>> rate>> ] tri ; M: vorbis-stream generate-audio - drop f f ; + dup decode-audio + [ [ drop ] 2dip ] + [ drop [ buffer-data-from-stream drop ] [ sync-pages ] [ decode-audio ] tri ] if* ; From ef5baa5b67b6772d1878d166007e5af5a8900db5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 24 Jan 2010 15:40:34 -0600 Subject: [PATCH 54/72] Handle IPv6 addresses of the form ::127.0.0.1 --- basis/io/sockets/sockets-tests.factor | 3 ++ basis/io/sockets/sockets.factor | 41 +++++++++++++++++++-------- 2 files changed, 32 insertions(+), 12 deletions(-) diff --git a/basis/io/sockets/sockets-tests.factor b/basis/io/sockets/sockets-tests.factor index 0964cdc148..5f6071b8ae 100644 --- a/basis/io/sockets/sockets-tests.factor +++ b/basis/io/sockets/sockets-tests.factor @@ -49,6 +49,9 @@ io.streams.string ; [ "1:2:0:0:0:0:3:4" ] [ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test +[ B{ 0 0 0 0 0 0 0 0 0 127 0 0 0 0 0 1 } ] +[ "::127.0.0.1" T{ inet6 } inet-pton ] unit-test + [ "2001:6f8:37a:5:0:0:0:1" ] [ "2001:6f8:37a:5::1" T{ inet6 } [ inet-pton ] [ inet-ntop ] bi ] unit-test diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index af21dac9b7..465813a711 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -64,21 +64,25 @@ C: inet4 M: inet4 inet-ntop ( data addrspec -- str ) drop 4 memory>byte-array [ number>string ] { } map-as "." join ; +ERROR: malformed-inet4 sequence ; +ERROR: bad-inet4-component string ; + +: parse-inet4 ( string -- seq ) + "." split dup length 4 = [ + malformed-inet4 + ] unless + [ + string>number + [ "Dotted component not a number" throw ] unless* + ] B{ } map-as ; + ERROR: invalid-inet4 string reason ; M: invalid-inet4 summary drop "Invalid IPv4 address" ; M: inet4 inet-pton ( str addrspec -- data ) drop - [ - "." split dup length 4 = [ - "Must have four components" throw - ] unless - [ - string>number - [ "Dotted component not a number" throw ] unless* - ] B{ } map-as - ] [ invalid-inet4 ] recover ; + [ parse-inet4 ] [ invalid-inet4 ] recover ; M: inet4 address-size drop 4 ; @@ -112,11 +116,24 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ; ] map + [ { f 0 } swap member? ] all? [ bad-ipv4-embedded-prefix ] unless ; + : parse-inet6 ( string -- seq ) [ f ] [ - ":" split [ - hex> [ "Component not a number" throw ] unless* - ] { } map-as + ":" split CHAR: . over last member? [ + unclip-last + [ ensure-zero-prefix drop ] [ parse-inet4 ] bi* + ] [ + [ + dup hex> [ nip ] [ bad-ipv6-component ] if* + ] { } map-as + ] if ] if-empty ; : pad-inet6 ( string1 string2 -- seq ) From af966734586e49709b168190893ecdf3cbbc9677 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 24 Jan 2010 15:57:06 -0600 Subject: [PATCH 55/72] Better fix for ipv6 --- basis/io/sockets/sockets-tests.factor | 3 +++ basis/io/sockets/sockets.factor | 11 ++++------- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/io/sockets/sockets-tests.factor b/basis/io/sockets/sockets-tests.factor index 5f6071b8ae..96ffbc5e18 100644 --- a/basis/io/sockets/sockets-tests.factor +++ b/basis/io/sockets/sockets-tests.factor @@ -52,6 +52,9 @@ io.streams.string ; [ B{ 0 0 0 0 0 0 0 0 0 127 0 0 0 0 0 1 } ] [ "::127.0.0.1" T{ inet6 } inet-pton ] unit-test +[ B{ 0 2 0 0 0 0 0 9 0 127 0 0 0 0 0 1 } ] +[ "2::9:127.0.0.1" T{ inet6 } inet-pton ] unit-test + [ "2001:6f8:37a:5:0:0:0:1" ] [ "2001:6f8:37a:5::1" T{ inet6 } [ inet-pton ] [ inet-ntop ] bi ] unit-test diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 465813a711..59d12f95bc 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -120,19 +120,16 @@ ERROR: bad-ipv6-component obj ; ERROR: bad-ipv4-embedded-prefix obj ; -: ensure-zero-prefix ( seq -- seq ) - dup [ hex> ] map - [ { f 0 } swap member? ] all? [ bad-ipv4-embedded-prefix ] unless ; +: parse-ipv6-component ( seq -- seq' ) + [ dup hex> [ nip ] [ bad-ipv6-component ] if* ] { } map-as ; : parse-inet6 ( string -- seq ) [ f ] [ ":" split CHAR: . over last member? [ unclip-last - [ ensure-zero-prefix drop ] [ parse-inet4 ] bi* + [ parse-ipv6-component ] [ parse-inet4 ] bi* append ] [ - [ - dup hex> [ nip ] [ bad-ipv6-component ] if* - ] { } map-as + parse-ipv6-component ] if ] if-empty ; From 942f6e0943cb953b2e6c4e7b7deaf0c32e3336a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 24 Jan 2010 07:17:18 -0600 Subject: [PATCH 56/72] Update Win64 support --- Nmakefile | 11 +++++++++++ basis/cpu/x86/64/64.factor | 18 +++++++----------- basis/cpu/x86/64/winnt/winnt.factor | 2 +- vm/Config.windows.nt.x86.64 | 1 - vm/bitwise_hacks.hpp | 3 ++- vm/code_blocks.cpp | 7 ------- vm/cpu-x86.hpp | 2 +- vm/errors.cpp | 2 +- vm/ffi_test.h | 6 +++++- vm/full_collector.cpp | 2 +- vm/instruction_operands.cpp | 6 +++--- vm/instruction_operands.hpp | 2 +- vm/master.hpp | 8 ++------ vm/math.cpp | 6 +++--- vm/os-windows-nt.64.hpp | 1 - vm/os-windows-nt.cpp | 4 ++++ vm/run.cpp | 2 +- vm/strings.cpp | 2 +- vm/vm.hpp | 5 ++--- 19 files changed, 46 insertions(+), 44 deletions(-) diff --git a/Nmakefile b/Nmakefile index e964105d9f..07984e35c8 100755 --- a/Nmakefile +++ b/Nmakefile @@ -1,5 +1,10 @@ +!IF DEFINED(DEBUG) +LINK_FLAGS = /nologo /DEBUG shell32.lib +CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG +!ELSE LINK_FLAGS = /nologo shell32.lib CL_FLAGS = /nologo /O2 /W3 +!ENDIF EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res @@ -50,11 +55,17 @@ DLL_OBJS = vm\os-windows-nt.obj \ .cpp.obj: cl /EHsc $(CL_FLAGS) /Fo$@ /c $< +.c.obj: + cl $(CL_FLAGS) /Fo$@ /c $< + .rs.res: rc $< all: factor.com factor.exe +libfactor-ffi-test.dll: vm/ffi_test.obj + link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj + factor.dll.lib: $(DLL_OBJS) link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index d3196397c3..5213030bdf 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math namespaces make sequences -system layouts alien alien.c-types alien.accessors slots -splitting assocs combinators locals compiler.constants +system layouts alien alien.c-types alien.accessors alien.libraries +slots splitting assocs combinators locals compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame @@ -118,9 +118,6 @@ M:: x86.64 %unbox ( n rep func -- ) ! this is the end of alien-callback n [ n rep reg-class-of return-reg rep %save-param-reg ] when ; -M: x86.64 %unbox-long-long ( n func -- ) - [ int-rep ] dip %unbox ; - : %unbox-struct-field ( c-type i -- ) ! Alien must be in param-reg-0. R11 swap cells [+] swap rep>> reg-class-of { @@ -163,12 +160,11 @@ M:: x86.64 %box ( n rep func -- ) ] [ rep load-return-value ] if - rep int-rep? [ param-reg-1 ] [ param-reg-0 ] if %mov-vm-ptr + rep int-rep? + cpu x86.64? os windows? and or + param-reg-1 param-reg-0 ? %mov-vm-ptr func f %alien-invoke ; -M: x86.64 %box-long-long ( n func -- ) - [ int-rep ] dip %box ; - : box-struct-field@ ( i -- operand ) 1 + cells param@ ; : %box-struct-field ( c-type i -- ) @@ -258,7 +254,7 @@ M: x86.64 %callback-value ( ctype -- ) M:: x86.64 %unary-float-function ( dst src func -- ) 0 src float-function-param - func f %alien-invoke + func "libm" load-library %alien-invoke dst float-function-return ; M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) @@ -266,7 +262,7 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) ! src2 is always a spill slot 0 src1 float-function-param 1 src2 float-function-param - func f %alien-invoke + func "libm" load-library %alien-invoke dst float-function-return ; M:: x86.64 %call-gc ( gc-root-count temp -- ) diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index a398c6565c..c75bb5a1b9 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -22,5 +22,5 @@ M: x86.64 dummy-int-params? t ; M: x86.64 dummy-fp-params? t ; -M: x86.64 temp-reg RAX ; +M: x86.64 temp-reg R11 ; diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.nt.x86.64 index 13ef665b19..ddb61480e5 100644 --- a/vm/Config.windows.nt.x86.64 +++ b/vm/Config.windows.nt.x86.64 @@ -1,4 +1,3 @@ -#error "lol" DLL_PATH=http://factorcode.org/dlls/64 CC=$(WIN64_PATH)-gcc.exe WINDRES=$(WIN64_PATH)-windres.exe diff --git a/vm/bitwise_hacks.hpp b/vm/bitwise_hacks.hpp index 1927cd4736..162d9272c6 100755 --- a/vm/bitwise_hacks.hpp +++ b/vm/bitwise_hacks.hpp @@ -12,7 +12,8 @@ inline cell log2(cell x) #endif #elif defined(FACTOR_AMD64) #if defined(_MSC_VER) - _BitScanReverse64(&n,x); + n = 0; + _BitScanReverse64((DWORD *)&n,x); #else asm ("bsr %1, %0;":"=r"(n):"r"(x)); #endif diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index 89106499da..f523dac3a0 100755 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -129,13 +129,6 @@ void factor_vm::update_word_references(code_block *compiled) } } -void factor_vm::check_code_address(cell address) -{ -#ifdef FACTOR_DEBUG - assert(address >= code->seg->start && address < code->seg->end); -#endif -} - /* References to undefined symbols are patched up to call this function on image load */ void factor_vm::undefined_symbol() diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index c96291b0d7..97e5a20305 100644 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -42,7 +42,7 @@ inline static void *get_call_target(cell return_address) inline static void set_call_target(cell return_address, void *target) { check_call_site(return_address); - *(int *)(return_address - 4) = ((cell)target - return_address); + *(int *)(return_address - 4) = (u32)((cell)target - return_address); } inline static bool tail_call_site_p(cell return_address) diff --git a/vm/errors.cpp b/vm/errors.cpp index 2dcb773dd1..ae560012aa 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -113,7 +113,7 @@ void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack) general_error(ERROR_MEMORY,allot_cell(addr),false_object,native_stack); } -void factor_vm::signal_error(int signal, stack_frame *native_stack) +void factor_vm::signal_error(cell signal, stack_frame *native_stack) { general_error(ERROR_SIGNAL,allot_cell(signal),false_object,native_stack); } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index af0c0b46a4..661f3b64de 100644 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -1,4 +1,8 @@ -#include +#ifdef _MSC_VER + #define WINDOWS +#else + #include +#endif #if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) #define F_STDCALL __attribute__((stdcall)) diff --git a/vm/full_collector.cpp b/vm/full_collector.cpp index 4de2814f1d..ec0972e952 100644 --- a/vm/full_collector.cpp +++ b/vm/full_collector.cpp @@ -51,7 +51,7 @@ void factor_vm::update_code_roots_for_sweep() for(; iter < end; iter++) { code_root *root = *iter; - code_block *block = (code_block *)(root->value & -data_alignment); + code_block *block = (code_block *)(root->value & (~data_alignment - 1)); if(root->valid && !state->marked_p(block)) root->valid = false; } diff --git a/vm/instruction_operands.cpp b/vm/instruction_operands.cpp index db869d9d01..59dbf1ef8e 100644 --- a/vm/instruction_operands.cpp +++ b/vm/instruction_operands.cpp @@ -82,7 +82,7 @@ void instruction_operand::store_value_2_2(fixnum value) void instruction_operand::store_value_masked(fixnum value, cell mask, cell shift) { u32 *ptr = (u32 *)(pointer - sizeof(u32)); - *ptr = ((*ptr & ~mask) | ((value >> shift) & mask)); + *ptr = (u32)((*ptr & ~mask) | ((value >> shift) & mask)); } void instruction_operand::store_value(fixnum absolute_value) @@ -95,10 +95,10 @@ void instruction_operand::store_value(fixnum absolute_value) *(cell *)(pointer - sizeof(cell)) = absolute_value; break; case RC_ABSOLUTE: - *(u32 *)(pointer - sizeof(u32)) = absolute_value; + *(u32 *)(pointer - sizeof(u32)) = (u32)absolute_value; break; case RC_RELATIVE: - *(s32 *)(pointer - sizeof(s32)) = relative_value; + *(s32 *)(pointer - sizeof(s32)) = (s32)relative_value; break; case RC_ABSOLUTE_PPC_2_2: store_value_2_2(absolute_value); diff --git a/vm/instruction_operands.hpp b/vm/instruction_operands.hpp index d46b5cf391..dc8aa9d841 100644 --- a/vm/instruction_operands.hpp +++ b/vm/instruction_operands.hpp @@ -69,7 +69,7 @@ struct relocation_entry { relocation_class rel_class, cell offset) { - value = (rel_type << 28) | (rel_class << 24) | offset; + value = (u32)((rel_type << 28) | (rel_class << 24) | offset); } relocation_type rel_type() diff --git a/vm/master.hpp b/vm/master.hpp index f4c0934478..70736c1bd9 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -32,10 +32,10 @@ /* Detect target CPU type */ #if defined(__arm__) #define FACTOR_ARM -#elif defined(__amd64__) || defined(__x86_64__) +#elif defined(__amd64__) || defined(__x86_64__) || defined(_M_AMD64) #define FACTOR_AMD64 #define FACTOR_64 -#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) || defined(_MSC_VER) +#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(_M_IX86) #define FACTOR_X86 #elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) #define FACTOR_PPC @@ -50,10 +50,6 @@ #define WINDOWS #endif -#ifndef _MSC_VER - #include -#endif - /* Forward-declare this since it comes up in function prototypes */ namespace factor { diff --git a/vm/math.cpp b/vm/math.cpp index a2c69c31f2..ef4a599331 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -203,7 +203,7 @@ void factor_vm::primitive_bignum_not() void factor_vm::primitive_bignum_bitp() { - fixnum bit = to_fixnum(ctx->pop()); + int bit = (int)to_fixnum(ctx->pop()); bignum *x = untag(ctx->pop()); ctx->push(tag_boolean(bignum_logbitp(bit,x))); } @@ -226,7 +226,7 @@ unsigned int bignum_producer(unsigned int digit, factor_vm *parent) void factor_vm::primitive_byte_array_to_bignum() { - cell n_digits = array_capacity(untag_check(ctx->peek())); + unsigned int n_digits = (unsigned int)array_capacity(untag_check(ctx->peek())); bignum * result = digit_stream_to_bignum(n_digits,factor::bignum_producer,0x100,0); ctx->replace(tag(result)); } @@ -352,7 +352,7 @@ void factor_vm::primitive_float_bits() void factor_vm::primitive_bits_float() { - ctx->push(allot_float(bits_float(to_cell(ctx->pop())))); + ctx->push(allot_float(bits_float((u32)to_cell(ctx->pop())))); } void factor_vm::primitive_double_bits() diff --git a/vm/os-windows-nt.64.hpp b/vm/os-windows-nt.64.hpp index b64bd607cb..aff662a489 100755 --- a/vm/os-windows-nt.64.hpp +++ b/vm/os-windows-nt.64.hpp @@ -4,7 +4,6 @@ namespace factor #define ESP Rsp #define EIP Rip -#define X87SW(ctx) (ctx)->FloatSave.StatusWord #define MXCSR(ctx) (ctx)->MxCsr } diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 2fceb130f4..cf5878e5bf 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -91,8 +91,12 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) case STATUS_FLOAT_UNDERFLOW: case STATUS_FLOAT_MULTIPLE_FAULTS: case STATUS_FLOAT_MULTIPLE_TRAPS: +#ifdef FACTOR_AMD64 + signal_fpu_status = fpu_status(MXCSR(c)); +#else signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c)); X87SW(c) = 0; +#endif MXCSR(c) &= 0xffffffc0; c->EIP = (cell)factor::fp_signal_handler_impl; break; diff --git a/vm/run.cpp b/vm/run.cpp index dfff8f2f2d..6c8a8452e7 100755 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -5,7 +5,7 @@ namespace factor void factor_vm::primitive_exit() { - exit(to_fixnum(ctx->pop())); + exit((int)to_fixnum(ctx->pop())); } void factor_vm::primitive_system_micros() diff --git a/vm/strings.cpp b/vm/strings.cpp index 67e4fb4508..5aad936a9e 100644 --- a/vm/strings.cpp +++ b/vm/strings.cpp @@ -81,7 +81,7 @@ void factor_vm::fill_string(string *str_, cell start, cell capacity, cell fill) data_root str(str_,this); if(fill <= 0x7f) - memset(&str->data()[start],fill,capacity - start); + memset(&str->data()[start],(int)fill,capacity - start); else { cell i; diff --git a/vm/vm.hpp b/vm/vm.hpp index 6fb788d531..6b12cc42c0 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -149,7 +149,7 @@ struct factor_vm void not_implemented_error(); bool in_page(cell fault, cell area, cell area_size, int offset); void memory_protection_error(cell addr, stack_frame *native_stack); - void signal_error(int signal, stack_frame *native_stack); + void signal_error(cell signal, stack_frame *native_stack); void divide_by_zero_error(); void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top); void primitive_call_clear(); @@ -509,7 +509,6 @@ struct factor_vm cell compute_entry_point_pic_tail_address(cell w_); cell code_block_owner(code_block *compiled); void update_word_references(code_block *compiled); - void check_code_address(cell address); void undefined_symbol(); cell compute_dlsym_address(array *literals, cell index); cell compute_vm_address(cell arg); @@ -524,7 +523,7 @@ struct factor_vm inline void check_code_pointer(cell ptr) { #ifdef FACTOR_DEBUG - assert(in_code_heap_p(ptr)); + //assert(in_code_heap_p(ptr)); #endif } From 14de77d435187efe0d4695747a36e8ea7bd9ef99 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 24 Jan 2010 20:16:10 -0800 Subject: [PATCH 57/72] inline specialized-vector byte-length --- basis/specialized-vectors/specialized-vectors.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor index f71e308ad1..7fa47aa501 100644 --- a/basis/specialized-vectors/specialized-vectors.factor +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -24,9 +24,9 @@ WHERE V A vectors.functor:define-vector -M: V contract 2drop ; +M: V contract 2drop ; inline -M: V byte-length underlying>> byte-length ; +M: V byte-length underlying>> byte-length ; inline M: V pprint-delims drop \ V{ \ } ; From 841e267f0a0013a3c747b68126223eaa9721cbe3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 24 Jan 2010 21:28:59 -0800 Subject: [PATCH 58/72] tweak audio.vorbis to queue up a fixed-sized preallocated buffer instead of taking ogg packets in whatever bizarre size they come --- extra/audio/vorbis/vorbis.factor | 81 ++++++++++++++++++++------------ 1 file changed, 51 insertions(+), 30 deletions(-) diff --git a/extra/audio/vorbis/vorbis.factor b/extra/audio/vorbis/vorbis.factor index ca712b8359..6d27d7040e 100644 --- a/extra/audio/vorbis/vorbis.factor +++ b/extra/audio/vorbis/vorbis.factor @@ -1,6 +1,6 @@ ! (c)2007, 2010 Chris Double, Joe Groff bsd license USING: accessors alien.c-types audio.engine byte-arrays classes.struct -combinators destructors fry gpu.buffers io io.files io.encodings.binary +combinators destructors fry io io.files io.encodings.binary kernel libc locals make math math.order math.parser ogg ogg.vorbis sequences specialized-arrays specialized-vectors ; FROM: alien.c-types => float short void* ; @@ -10,6 +10,7 @@ IN: audio.vorbis TUPLE: vorbis-stream < disposable stream + { buffer byte-array } { packet ogg-packet } { sync-state ogg-sync-state } { page ogg-page } @@ -19,8 +20,7 @@ TUPLE: vorbis-stream < disposable { block vorbis-block } { comment vorbis-comment } { temp-state ogg-stream-state } - { #vorbis-headers integer initial: 0 } - { stream-eof? boolean } ; + { #vorbis-headers integer initial: 0 } ; CONSTANT: stream-buffer-size 4096 @@ -61,8 +61,10 @@ ERROR: no-vorbis-in-ogg ; : retrieve-page ( vorbis-stream -- ? ) [ sync-state>> ] [ page>> ] bi ogg_sync_pageout 0 > ; inline -: sync-pages ( vorbis-stream -- ) - dup retrieve-page [ [ queue-page ] [ sync-pages ] bi ] [ drop ] if ; +: (sync-pages) ( vorbis-stream ? -- ? ) + over retrieve-page [ [ drop queue-page ] [ drop t (sync-pages) ] 2bi ] [ nip ] if ; +: sync-pages ( vorbis-stream -- ? ) + f (sync-pages) ; inline : standard-initial-header? ( vorbis-stream -- bool ) page>> ogg_page_bos zero? not ; inline @@ -152,23 +154,28 @@ ERROR: no-vorbis-in-ogg ; : get-pending-decoded-audio ( vorbis-stream -- pcm len ) dsp-state>> f [ vorbis_synthesis_pcmout ] keep *void* swap ; -:: make-pcm-buffer ( vorbis-stream pcm len -- short-array ) - vorbis-stream info>> channels>> :> #channels - pcm #channels :> channel*s - #channels len * :> output +: float>short-sample ( float -- short ) + -32767.5 * 0.5 - >integer -32768 32767 clamp ; inline - len iota [| sample | +:: write-pcm-to-buffer ( vorbis-stream offset pcm len -- offset' ) + vorbis-stream buffer>> :> buffer + buffer length -1 shift :> buffer-length + offset -1 shift :> sample-offset + buffer buffer-length sample-offset short-vector boa :> short-buffer + vorbis-stream info>> channels>> :> #channels + buffer-length sample-offset - #channels /i :> max-len + len max-len min :> len' + pcm #channels :> channel*s + + len' iota [| sample | #channels iota [| channel | - channel channel*s nth len :> samples - sample samples nth - -32767.0 * >integer -32767 32767 clamp - output push + channel channel*s nth len + sample swap nth + float>short-sample short-buffer push ] each ] each - output >short-array ; inline - -: read-samples ( vorbis-stream pcm len -- ) - [ dsp-state>> ] [ drop ] [ ] tri* vorbis_synthesis_read drop ; inline + vorbis-stream dsp-state>> len' vorbis_synthesis_read drop + short-buffer length 1 shift ; inline : queue-audio ( vorbis-stream -- ? ) dup [ stream-state>> ] [ packet>> ] bi ogg_stream_packetout 0 > [ @@ -177,18 +184,34 @@ ERROR: no-vorbis-in-ogg ; ] [ drop ] if t ] [ drop f ] if ; -: decode-audio ( vorbis-stream -- short-array/f length/f ) - dup get-pending-decoded-audio dup 0 > [ - [ make-pcm-buffer dup byte-length ] [ read-samples ] 3bi - ] [ - 2drop dup queue-audio [ decode-audio ] [ drop f f ] if +: (decode-audio) ( vorbis-stream offset -- offset' ) + over get-pending-decoded-audio dup 0 > [ write-pcm-to-buffer ] [ + 2drop over queue-audio [ (decode-audio) ] [ nip ] if ] if ; + +: decode-audio ( vorbis-stream offset -- offset' ) + 2dup (decode-audio) { + { + [ 3dup [ buffer>> length ] [ drop ] [ ] tri* = ] + [ 2nip ] + } + { + [ 2dup = ] + [ + drop + [ drop buffer-data-from-stream drop ] + [ over sync-pages [ decode-audio ] [ nip ] if ] 2bi + ] + } + [ nip decode-audio ] + } cond ; PRIVATE> -: ( stream -- vorbis-stream ) +:: ( stream buffer-size -- vorbis-stream ) [ vorbis-stream new-disposable - swap >>stream + stream >>stream + buffer-size >>buffer ogg-packet malloc-struct |free >>packet ogg-sync-state malloc-struct |free >>sync-state ogg-page malloc-struct |free >>page @@ -206,8 +229,8 @@ PRIVATE> } cleave ] with-destructors ; -: read-vorbis-stream ( filename -- vorbis-stream ) - binary ; inline +: read-vorbis-stream ( filename buffer-size -- vorbis-stream ) + [ binary ] dip ; inline M: vorbis-stream dispose* { @@ -225,6 +248,4 @@ M: vorbis-stream dispose* M: vorbis-stream generator-audio-format [ info>> channels>> ] [ drop 16 ] [ info>> rate>> ] tri ; M: vorbis-stream generate-audio - dup decode-audio - [ [ drop ] 2dip ] - [ drop [ buffer-data-from-stream drop ] [ sync-pages ] [ decode-audio ] tri ] if* ; + [ buffer>> ] [ 0 decode-audio ] bi ; From ad2ae73b67892efd30f0bd40ee62520d8ad7a64b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jan 2010 18:02:38 +1300 Subject: [PATCH 59/72] mason.child: run nmake on Windows --- extra/mason/child/child-tests.factor | 2 +- extra/mason/child/child.factor | 9 ++++++--- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 2d5a7c6635..6fedac87bd 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -1,7 +1,7 @@ IN: mason.child.tests USING: mason.child mason.config tools.test namespaces io kernel sequences ; -[ { "make" "winnt-x86-32" } ] [ +[ { "nmake" "/f" "nmakefile" } ] [ [ "winnt" target-os set "x86.32" target-cpu set diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index 193ac1e212..017e4401d8 100644 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -1,14 +1,17 @@ -! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays calendar combinators.short-circuit fry continuations debugger io.directories io.files io.launcher io.pathnames io.encodings.ascii kernel make mason.common mason.config mason.platform mason.report mason.notify namespaces sequences -quotations macros ; +quotations macros system combinators ; IN: mason.child : make-cmd ( -- args ) - gnu-make platform 2array ; + { + { [ target-os get "winnt" = ] [ { "nmake" "/f" "nmakefile" } ] } + [ gnu-make platform 2array ] + } cond ; : make-vm ( -- ) "factor" [ From aadf2873d11723ff78f7a8d289eba2c578867b1e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jan 2010 19:10:17 +1300 Subject: [PATCH 60/72] ui.gadgets: make fast-children-on more flexible and take a quotation instead of always calling loc>> on elements of the children array. This enables a bug fix for M\ grid children-on, discovered from UI mis-rendering of '\ blend-mode help' --- basis/ui/gadgets/gadgets.factor | 21 ++++++++++---------- basis/ui/gadgets/grids/grids-tests.factor | 24 +++++++++++++++++++++-- basis/ui/gadgets/grids/grids.factor | 13 +++++++----- basis/ui/gadgets/packs/packs.factor | 5 ++--- basis/ui/gadgets/panes/panes.factor | 5 +++-- 5 files changed, 46 insertions(+), 22 deletions(-) diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 8eb11a7753..7e47bf627b 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables kernel math namespaces make sequences quotations math.vectors combinators sorting @@ -62,18 +62,19 @@ M: gadget children-on nip children>> ; ) - [ swap loc>> v- ] dip v. 0 <=> ; - -:: (fast-children-on) ( dim axis children -- i ) - children [ dim axis ((fast-children-on)) ] search drop ; +:: (fast-children-on) ( point axis children quot -- i ) + children [ + [ point ] dip + quot call( value -- loc ) v- + axis v. 0 <=> + ] search drop ; inline PRIVATE> -: fast-children-on ( rect axis children -- from to ) - [ [ loc>> ] 2dip (fast-children-on) 0 or ] - [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ] - 3bi ; +:: fast-children-on ( rect axis children quot -- slice ) + rect loc>> axis children quot (fast-children-on) 0 or + rect rect-bounds v+ axis children quot (fast-children-on) ?1+ + children ; inline M: gadget contains-rect? ( bounds gadget -- ? ) dup visible?>> [ call-next-method ] [ 2drop f ] if ; diff --git a/basis/ui/gadgets/grids/grids-tests.factor b/basis/ui/gadgets/grids/grids-tests.factor index b83f1a7003..3dc0e6b862 100644 --- a/basis/ui/gadgets/grids/grids-tests.factor +++ b/basis/ui/gadgets/grids/grids-tests.factor @@ -1,12 +1,14 @@ USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays namespaces math.rectangles accessors ui.gadgets.grids.private -ui.gadgets.debug sequences ; +ui.gadgets.debug sequences classes ; IN: ui.gadgets.grids.tests [ { 0 0 } ] [ { } pref-dim ] unit-test : 100x100 ( -- gadget ) { 100 100 } >>dim ; +: 200x200 ( -- gadget ) { 200 200 } >>dim ; + [ { 100 100 } ] [ 100x100 1array 1array pref-dim @@ -81,4 +83,22 @@ IN: ui.gadgets.grids.tests "g" get dup layout children>> [ loc>> ] map -] unit-test \ No newline at end of file +] unit-test + +! children-on logic was insufficient +[ ] [ + 100x100 dup "a" set 200x200 2array + 100x100 dup "b" set 200x200 2array 2array f >>fill? "g" set +] unit-test + +[ ] [ "g" get prefer ] unit-test +[ ] [ "g" get layout ] unit-test + +[ { 0 50 } ] [ "a" get loc>> ] unit-test +[ { 0 250 } ] [ "b" get loc>> ] unit-test + +[ gadget { 200 200 } ] +[ { 120 20 } "g" get pick-up [ class ] [ dim>> ] bi ] unit-test + +[ gadget { 200 200 } ] +[ { 120 220 } "g" get pick-up [ class ] [ dim>> ] bi ] unit-test \ No newline at end of file diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 9b5b737406..2e964b48b6 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2006, 2009 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.order math.matrices namespaces make sequences words io -math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables +USING: arrays kernel math math.order math.matrices namespaces +make sequences words io math.vectors ui.gadgets +ui.baseline-alignment columns accessors strings.tables math.rectangles fry ; IN: ui.gadgets.grids @@ -115,8 +116,10 @@ M: grid layout* [ grid>> ] [ ] bi grid-layout ; M: grid children-on ( rect gadget -- seq ) dup children>> empty? [ 2drop f ] [ - [ { 0 1 } ] dip grid>> - [ 0 fast-children-on ] [ concat ] bi + [ { 0 1 } ] dip + [ grid>> ] [ dim>> ] bi + '[ _ [ loc>> vmin ] reduce ] fast-children-on + concat ] if ; M: grid gadget-text* diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index f47b374aeb..5f21d74180 100644 --- a/basis/ui/gadgets/packs/packs.factor +++ b/basis/ui/gadgets/packs/packs.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences ui.gadgets ui.baseline-alignment ui.baseline-alignment.private kernel math math.functions math.vectors @@ -100,5 +100,4 @@ M: pack layout* dup children>> pref-dims pack-layout ; M: pack children-on ( rect gadget -- seq ) - [ orientation>> ] [ children>> ] bi - [ fast-children-on ] keep ; + [ orientation>> ] [ children>> ] bi [ loc>> ] fast-children-on ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 50a609b897..8fec7e45ce 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel namespaces sequences strings quotations math opengl combinators memoize math.vectors @@ -352,7 +352,8 @@ M: paragraph stream-format GENERIC: sloppy-pick-up* ( loc gadget -- n ) M: pack sloppy-pick-up* ( loc gadget -- n ) - [ orientation>> ] [ children>> ] bi (fast-children-on) ; + [ orientation>> ] [ children>> ] bi + [ loc>> ] (fast-children-on) ; M: gadget sloppy-pick-up* children>> [ contains-point? ] with find-last drop ; From d4435ed32af75c088e7ee00bcfce02169504efce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jan 2010 19:20:13 +1300 Subject: [PATCH 61/72] command-line: if -e= is passed, don't run main vocab after evaluation ends --- basis/bootstrap/finish-bootstrap.factor | 11 ++++++++--- basis/command-line/command-line-docs.factor | 4 ---- basis/command-line/command-line.factor | 3 --- 3 files changed, 8 insertions(+), 10 deletions(-) diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor index 70ccaedad4..387903d1e9 100644 --- a/basis/bootstrap/finish-bootstrap.factor +++ b/basis/bootstrap/finish-bootstrap.factor @@ -8,9 +8,14 @@ namespaces eval kernel vocabs.loader io ; (command-line) parse-command-line load-vocab-roots run-user-init - "e" get [ eval( -- ) ] when* - ignore-cli-args? not script get and - [ run-script ] [ "run" get run ] if* + + "e" get script get or [ + "e" get [ eval( -- ) ] when* + script get [ run-script ] when* + ] [ + "run" get run + ] if + output-stream get [ stream-flush ] when* 0 exit ] [ print-error 1 exit ] recover diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index 697f95b14f..11ee46c227 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -37,10 +37,6 @@ HELP: main-vocab HELP: default-cli-args { $description "Sets global variables corresponding to default command line arguments." } ; -HELP: ignore-cli-args? -{ $values { "?" "a boolean" } } -{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ; - ARTICLE: "runtime-cli-args" "Command line switches for the VM" "A handful of command line switches are processed by the VM and not the library. They control low-level features." { $table diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 939fb82f00..643afef669 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -67,7 +67,4 @@ SYMBOL: main-vocab-hook main-vocab "run" set ] bind ; -: ignore-cli-args? ( -- ? ) - os macosx? "run" get "ui" = and ; - [ default-cli-args ] "command-line" add-startup-hook From de3168ad7119906f949fcbcd902b593bafa757cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Jan 2010 01:01:12 +1300 Subject: [PATCH 62/72] Various documentation improvements --- basis/compression/lzw/lzw-docs.factor | 4 +- basis/eval/eval-docs.factor | 60 +++++++++++++++++-- basis/listener/listener-docs.factor | 7 ++- .../stylesheet/stylesheet-docs.factor | 14 ++--- basis/vocabs/refresh/refresh-docs.factor | 8 ++- core/parser/parser-docs.factor | 32 ++++------ core/vocabs/loader/loader-docs.factor | 24 +++++--- core/vocabs/parser/parser-docs.factor | 2 +- extra/combinators/tuple/tuple-docs.factor | 2 +- 9 files changed, 105 insertions(+), 48 deletions(-) diff --git a/basis/compression/lzw/lzw-docs.factor b/basis/compression/lzw/lzw-docs.factor index dccfb25a39..28dc36902b 100644 --- a/basis/compression/lzw/lzw-docs.factor +++ b/basis/compression/lzw/lzw-docs.factor @@ -52,7 +52,7 @@ HELP: reset-lzw-uncompress } { $description "Reset the LZW uncompressor state (either at initialization time or immediately after receiving a Clear Code). " } ; -ARTICLE: "compression.lzw.differences" "LZW Differences between TIFF and GIF" +ARTICLE: "compression.lzw.differences" "LZW differences between TIFF and GIF" { $vocab-link "compression.lzw" } $nl "There are some subtle differences between the LZW algorithm used by TIFF and GIF images." @@ -66,7 +66,7 @@ $nl "TIFF and GIF both add the concept of a 'Clear Code' and a 'End of Information Code' to the LZW algorithm. In both cases, the 'Clear Code' is equal to 2**(code-size - 1) and the 'End of Information Code' is equal to the Clear Code + 1. These 2 codes are reserved in the string table. So in both cases, the LZW string table is initialized to have a length equal to the End of Information Code + 1." ; -ARTICLE: "compression.lzw" "LZW Compression" +ARTICLE: "compression.lzw" "LZW compression" { $vocab-link "compression.lzw" } $nl "Implements both the TIFF and GIF variations of the LZW algorithm." diff --git a/basis/eval/eval-docs.factor b/basis/eval/eval-docs.factor index 250241dcfc..2021a2d10d 100644 --- a/basis/eval/eval-docs.factor +++ b/basis/eval/eval-docs.factor @@ -1,25 +1,73 @@ IN: eval -USING: help.markup help.syntax strings io effects ; +USING: help.markup help.syntax strings io effects parser +listener vocabs.parser debugger combinators ; + +HELP: (eval) +{ $values { "str" string } { "effect" effect } } +{ $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." } +{ $notes "This word must be wrapped within " { $link with-file-vocabs } " or " { $link with-interactive-vocabs } ", since it assumes that the " { $link manifest } " variable is set in the current dynamic scope." } +{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ; HELP: eval { $values { "str" string } { "effect" effect } } { $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." } +{ $notes "The code string is parsed and called in a new dynamic scope with an initial vocabulary search path consisting of just the " { $snippet "syntax" } " vocabulary. The evaluated code can use " { $link "word-search-syntax" } " to alter the search path." } { $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ; HELP: eval( { $syntax "eval( inputs -- outputs )" } { $description "Parses Factor source code from the string at the top of the stack, and calls the resulting quotation, which must have the given stack effect." } +{ $notes + "This parsing word is just a slightly nicer syntax for " { $link eval } ". The following are equivalent:" + { $code + "eval( inputs -- outputs )" + "(( inputs -- outputs )) eval" + } +} { $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ; HELP: eval>string { $values { "str" string } { "output" string } } -{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } ; +{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } +{ $errors "If the code throws an error, the error is caught, and the result of calling " { $link print-error } " on the error is returned." } ; -ARTICLE: "eval" "Evaluating strings at runtime" -"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime." +ARTICLE: "eval-vocabs" "Evaluating strings with a different vocabulary search path" +"Strings passed to " { $link eval } " are always evaluated with an initial vocabulary search path consisting of just the " { $snippet "syntax" } " vocabulary. This is the same search path that source files start out with. This behavior can be customized by taking advantage of the fact that " { $link eval } " is composed from two simpler words:" +{ $subsections + (eval) + with-file-vocabs +} +"Code in the listener tool starts out with a different initial search path, with more vocabularies are available by default. Strings of code can be evaluated in this search path by using " { $link (eval) } " with a different combinator:" +{ $subsections + with-interactive-vocabs +} +"When using " { $link (eval) } ", the quotation passed to " { $link with-file-vocabs } " and " { $link with-interactive-vocabs } " can also make specific vocabularies available to the evaluated string. This is done by having the quotation change the run-time vocabulary search path prior to calling " { $link (eval) } ". For run-time analogues of the parse-time " { $link "word-search-syntax" } " see " { $link "word-search-parsing" } "." +$nl +"The vocabulary set used by " { $link with-interactive-vocabs } " can be altered by rebinding a dynamic variable:" +{ $subsections interactive-vocabs } +{ $heading "Example" } +"In this example, a string is evaluated with a fictional " { $snippet "cad.objects" } " vocabulary in the search path by default, together with the listener's " { $link interactive-vocabs } "; the quotation is expected to produce a sequence on the stack:" +{ $code + """USING: eval listener vocabs.parser ; +[ + "cad-objects" use-vocab + (( -- seq )) (eval) +] with-interactive-vocabs""" +} +"Note that the search path in the outer code (set by the " { $link POSTPONE: USING: } " form) has no relation to the search path used when parsing the string parameter (this is determined by " { $link with-interactive-vocabs } " and " { $link use-vocab } ")." ; + +ARTICLE: "eval" "Evaluating strings at run time" +"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings of code dynamically." +$nl +"The main entry point is a parsing word, which wraps a library word:" { $subsections POSTPONE: eval( - eval>string -} ; + eval +} +"This pairing is analogous to that of " { $link POSTPONE: call( } " with " { $link call-effect } "." +$nl +"Advanced features:" +{ $subsections "eval-vocabs" eval>string } +; ABOUT: "eval" diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index a054067755..77bec12c1a 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel io system prettyprint continuations ; +USING: help.markup help.syntax kernel io system prettyprint continuations quotations ; IN: listener ARTICLE: "listener-watch" "Watching variables in the listener" @@ -21,6 +21,11 @@ HELP: only-use-vocabs { $values { "vocabs" "a sequence of vocabulary specifiers" } } { $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ; +HELP: with-interactive-vocabs +{ $values { "quot" quotation } } +{ $description "Calls the quotation in a scope with an initial vocabulary search path consisting of all vocabularies from " { $link interactive-vocabs } ", and with the current vocabulary for new definitions set to " { $vocab-link "scratchpad" } "." } +{ $notes "This is the same initial search path as used by the " { $link "listener" } " tool." } ; + HELP: show-var { $values { "var" "a variable name" } } { $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ; diff --git a/basis/prettyprint/stylesheet/stylesheet-docs.factor b/basis/prettyprint/stylesheet/stylesheet-docs.factor index 60014514af..12781a568b 100644 --- a/basis/prettyprint/stylesheet/stylesheet-docs.factor +++ b/basis/prettyprint/stylesheet/stylesheet-docs.factor @@ -8,33 +8,31 @@ HELP: effect-style { "effect" "an effect" } { "style" "a style assoc" } } -{ $description "The styling hook for stack effects" } ; +{ $description "The stylesheet for stack effects" } ; HELP: string-style { $values { "str" "a string" } { "style" "a style assoc" } } -{ $description "The styling hook for string literals" } ; +{ $description "The stylesheet for string literals" } ; HELP: vocab-style { $values { "vocab" "a vocabulary specifier" } { "style" "a style assoc" } } -{ $description "The styling hook for vocab names" } ; +{ $description "The stylesheet for vocab names" } ; HELP: word-style { $values { "word" "a word" } { "style" "a style assoc" } } -{ $description "The styling hook for word names" } ; +{ $description "The stylesheet for word names" } ; -ARTICLE: "prettyprint.stylesheet" "Prettyprinter Formatted Output" -{ $vocab-link "prettyprint.stylesheet" } -$nl -"Control the way that the prettyprinter formats output based on object type. These hooks form a basic \"syntax\" highlighting system." +ARTICLE: "prettyprint.stylesheet" "Prettyprinter stylesheet" +"The " { $vocab-link "prettyprint.stylesheet" } " vocabulary defines variables which control the way that the prettyprinter formats output based on object type." { $subsections word-style string-style diff --git a/basis/vocabs/refresh/refresh-docs.factor b/basis/vocabs/refresh/refresh-docs.factor index b074a9e502..ee02a491e1 100644 --- a/basis/vocabs/refresh/refresh-docs.factor +++ b/basis/vocabs/refresh/refresh-docs.factor @@ -15,7 +15,13 @@ HELP: refresh-all { refresh refresh-all } related-words ARTICLE: "vocabs.refresh" "Runtime code reloading" -"Reloading source files changed on disk:" +"The " { $vocab-link "vocabs.refresh" } " vocabulary implements automatic reloading of changed source files." +$nl +"With the help of the " { $vocab-link "io.monitors" } " vocabulary, loaded source files across all vocabulary roots are monitored for changes on disk." +$nl +"If a change to a source file is detected, the next invocation of " { $link refresh-all } " will compare the file's checksum against its previous value, reloading the file if necessary. This takes advantage of the fact that the " { $vocab-link "source-files" } " vocabulary records CRC32 checksums of source files that have been parsed by " { $link "parser" } "." +$nl +"Words for reloading source files:" { $subsections refresh refresh-all diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 97dbab384e..42903a2cec 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -79,17 +79,6 @@ $nl "word-search-parsing" } ; -ARTICLE: "parser-files" "Parsing source files" -"The parser can run source files:" -{ $subsections - run-file - parse-file -} -"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions." -$nl -"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "." -{ $see-also "source-files" } ; - ARTICLE: "top-level-forms" "Top level forms" "Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file." $nl @@ -98,14 +87,19 @@ $nl "Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ; ARTICLE: "parser" "The parser" -"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies." +"The Factor parser reading textual representations of objects and definitions, with all syntax determined by " { $link "parsing-words" } ". The parser is implemented in the " { $vocab-link "parser" } " vocabulary, with standard syntax in the " { $vocab-link "syntax" } " vocabulary. See " { $link "syntax" } " for a description of standard syntax." $nl -"This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "." -{ $subsections "parser-files" } -"The parser can be extended." -{ $subsections "parser-lexer" } -"The parser can be invoked reflectively;" -{ $subsections parse-stream } +"The parser cross-references " { $link "source-files" } " and " { $link "definitions" } ". This functionality is used for improved error checking, as well as tools such as " { $link "tools.crossref" } " and " { $link "editor" } "." +$nl +"The parser can be invoked reflectively, to run strings and source files." +{ $subsections + "eval" + run-file + parse-file +} +"If Factor is run from the command line with a script file supplied as an argument, the script is run using " { $link run-file } ". See " { $link "cli" } "." +$nl +"While " { $link run-file } " can be used interactively in the listener to load user code into the session, this should only be done for quick one-off scripts, and real programs should instead rely on the automatic " { $link "vocabs.loader" } "." { $see-also "parsing-words" "definitions" "definition-checking" } ; ABOUT: "parser" @@ -204,7 +198,7 @@ HELP: bootstrap-syntax HELP: with-file-vocabs { $values { "quot" quotation } } -{ $description "Calls the quotation in a scope with the initial the vocabulary search path for parsing a file. This consists of just the " { $snippet "syntax" } " vocabulary." } ; +{ $description "Calls the quotation in a scope with an initial vocabulary search path consisting of just the " { $snippet "syntax" } " vocabulary." } ; HELP: parse-fresh { $values { "lines" "a sequence of strings" } { "quot" quotation } } diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 02a604ac32..f2da4a1383 100644 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -28,38 +28,44 @@ ARTICLE: "vocabs.roots" "Vocabulary roots" { $subsections "add-vocab-roots" } ; ARTICLE: "vocabs.loader" "Vocabulary loader" -"The vocabulary loader is defined in the " { $vocab-link "vocabs.loader" } " vocabulary." +"The vocabulary loader combines the vocabulary system with " { $link "parser" } " in order to implement automatic loading of vocabulary source files. The vocabulary loader is implemented in the " { $vocab-link "vocabs.loader" } " vocabulary." $nl -"Vocabularies are searched for in vocabulary roots." +"When an attempt is made to use a vocabulary that has not been loaded into the image, the vocabulary loader is asked to locate the vocabulary's source files, and load them." +$nl +"The vocabulary loader searches for vocabularies in a set of directories known as vocabulary roots." { $subsections "vocabs.roots" } -"Vocabulary names map directly to source files. A vocabulary named " { $snippet "foo.bar" } " must be defined in a " { $snippet "bar" } " directory nested inside a " { $snippet "foo" } " directory of a vocabulary root. Any level of vocabulary nesting is permitted." +"Vocabulary names map directly to source files inside these roots. A vocabulary named " { $snippet "foo.bar" } " is defined in " { $snippet "foo/bar/bar.factor" } "; that is, a source file named " { $snippet "bar.factor" } " within a " { $snippet "bar" } " directory nested inside a " { $snippet "foo" } " directory of a vocabulary root. Any level of nesting, separated by dots, is permitted." $nl "The vocabulary directory - " { $snippet "bar" } " in our example - contains a source file:" { $list - { { $snippet "foo/bar/bar.factor" } " - the source file, must define words in the " { $snippet "foo.bar" } " vocabulary with an " { $snippet "IN: foo.bar" } " form" } + { { $snippet "foo/bar/bar.factor" } " - the source file must define words in the " { $snippet "foo.bar" } " vocabulary with an " { $snippet "IN: foo.bar" } " form" } } -"Two other Factor source files, storing documentation and tests, respectively, are optional:" +"Two other Factor source files, storing documentation and tests, respectively, may optionally be placed alongside the source file:" { $list { { $snippet "foo/bar/bar-docs.factor" } " - documentation, see " { $link "writing-help" } } { { $snippet "foo/bar/bar-tests.factor" } " - unit tests, see " { $link "tools.test" } } } -"Finally, three text files can contain meta-data:" +"Finally, optional three text files may contain meta-data:" { $list { { $snippet "foo/bar/authors.txt" } " - a series of lines, with one author name per line. These are listed under " { $link "vocab-authors" } } { { $snippet "foo/bar/summary.txt" } " - a one-line description" } { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can re-use" } } -"While " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " load vocabularies which have not been loaded before adding them to the search path, it is also possible to load a vocabulary without adding it to the search path:" +"The " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " words load vocabularies which have not been loaded yet, as needed." +$nl +"Vocabularies can also be loaded at run time, without altering the vocabulary search path. This is done by calling a word which loads a vocabulary if it is not in the image, doing nothing if it is:" { $subsections require } -"Forcing a reload of a vocabulary, even if it has already been loaded:" +"The above word will only ever load a vocabulary once in a given session. There is another word which unconditionally loads vocabulary from disk, regardless of whether or not is has already been loaded:" { $subsections reload } +"For interactive development in the listener, calling " { $link reload } " directly is usually not necessary, since a better facility exists for " { $link "vocabs.refresh" } "." +$nl "Application vocabularies can define a main entry point, giving the user a convenient way to run the application:" { $subsections POSTPONE: MAIN: run runnable-vocab } -{ $see-also "vocabularies" "parser-files" "source-files" } ; +{ $see-also "vocabularies" "parser" "source-files" } ; ABOUT: "vocabs.loader" diff --git a/core/vocabs/parser/parser-docs.factor b/core/vocabs/parser/parser-docs.factor index 6a7bd4d212..66900978a8 100644 --- a/core/vocabs/parser/parser-docs.factor +++ b/core/vocabs/parser/parser-docs.factor @@ -65,7 +65,7 @@ $nl } { $see-also "words" } ; -ARTICLE: "word-search-parsing" "Word lookup in parsing words" +ARTICLE: "word-search-parsing" "Reflection support for vocabulary search path" "The parsing words described in " { $link "word-search-syntax" } " are implemented using the below words, which you can also call from your own parsing words." $nl "The current state used for word search is stored in a " { $emphasis "manifest" } ":" diff --git a/extra/combinators/tuple/tuple-docs.factor b/extra/combinators/tuple/tuple-docs.factor index d0eda50cd4..600986e906 100644 --- a/extra/combinators/tuple/tuple-docs.factor +++ b/extra/combinators/tuple/tuple-docs.factor @@ -33,7 +33,7 @@ HELP: nmake-tuple { make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words ARTICLE: "combinators.tuple" "Tuple-constructing combinators" -"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects." +"The " { $vocab-link "combinators.tuple" } " vocabulary provides combinators that construct " { $link tuple } " objects. These provide additional functionality above and beyond built-in " { $link "tuple-constructors" } "." { $subsections make-tuple 2make-tuple From cb9261d975de97c2b5bbe57d02951d80a1bc2d42 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Jan 2010 01:01:22 +1300 Subject: [PATCH 63/72] grouping: add a unit test --- basis/grouping/grouping-tests.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor index 52b436507e..60500558a7 100644 --- a/basis/grouping/grouping-tests.factor +++ b/basis/grouping/grouping-tests.factor @@ -30,3 +30,5 @@ IN: grouping.tests [ f ] [ [ 1.0 1 1 ] all-equal? ] unit-test [ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test [ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test + +[ { 6 7 8 3 4 5 0 1 2 } ] [ 9 iota >array dup 3 reverse! drop ] unit-test From 13e2de5cae5c921a43f733508f6c116319587eb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Jan 2010 01:01:27 +1300 Subject: [PATCH 64/72] help.lint: flush --- basis/help/lint/lint.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index e0cea42b4f..47b8820f18 100644 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -69,7 +69,7 @@ PRIVATE> '[ _ vocab-help [ article drop ] when* ] check-something ; : check-vocab ( vocab -- ) - "Checking " write dup write "..." print + "Checking " write dup write "..." print flush [ check-about ] [ words [ check-word ] each ] [ vocab-articles get at [ check-article ] each ] From 6306d58f77c7ab65638f5b25216040d4aa4bad87 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Jan 2010 01:18:10 +1300 Subject: [PATCH 65/72] help.crossref, tools.crossref: improved help cross-referencing --- basis/help/crossref/crossref.factor | 4 ++-- basis/tools/crossref/crossref.factor | 36 ++++++++++++++++++---------- 2 files changed, 26 insertions(+), 14 deletions(-) diff --git a/basis/help/crossref/crossref.factor b/basis/help/crossref/crossref.factor index 5e4922c7ad..36d780c99b 100644 --- a/basis/help/crossref/crossref.factor +++ b/basis/help/crossref/crossref.factor @@ -7,10 +7,10 @@ IN: help.crossref : article-links ( topic elements -- seq ) [ article-content ] dip - collect-elements [ >link ] map ; + collect-elements ; : article-children ( topic -- seq ) - { $subsection $subsections } article-links ; + { $subsection $subsections } article-links [ >link ] map ; : help-path ( topic -- seq ) [ article-parent ] follow rest ; diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index 134395f1a8..daa30100a4 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words assocs definitions io io.pathnames io.styles kernel -prettyprint sorting see sets sequences arrays hashtables help.crossref -help.topics help.markup quotations accessors source-files namespaces -graphs vocabs generic generic.single threads compiler.units init ; +prettyprint sorting see sets sequences arrays hashtables help +help.crossref help.topics help.markup quotations accessors +source-files namespaces graphs vocabs generic generic.single +threads compiler.units init combinators.smart ; IN: tools.crossref SYMBOL: crossref @@ -50,10 +51,16 @@ M: callable uses ( quot -- assoc ) M: word uses def>> uses ; -M: link uses { $subsection $subsections $link $see-also } article-links ; +M: link uses + [ { $subsection $subsections $link $see-also } article-links [ >link ] map ] + [ { $vocab-link } article-links [ >vocab-link ] map ] + bi append ; M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ; +! To make UI browser happy +M: vocab uses drop f ; + GENERIC: crossref-def ( defspec -- ) M: object crossref-def @@ -62,18 +69,23 @@ M: object crossref-def M: word crossref-def [ call-next-method ] [ subwords [ crossref-def ] each ] bi ; +: defs-to-crossref ( -- seq ) + [ + all-words + all-articles [ >link ] map + source-files get keys [ ] map + ] append-outputs ; + : build-crossref ( -- crossref ) "Computing usage index... " write flush yield - H{ } clone crossref [ - all-words - source-files get keys [ ] map - [ [ crossref-def ] each ] bi@ - crossref get - ] with-variable + H{ } clone [ + crossref set-global + defs-to-crossref [ crossref-def ] each + ] keep "done" print flush ; : get-crossref ( -- crossref ) - crossref global [ drop build-crossref ] cache ; + crossref get-global [ build-crossref ] unless* ; GENERIC: irrelevant? ( defspec -- ? ) From 3a00d2573a98a5956eb59d4533d67b7b22a81981 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 25 Jan 2010 13:14:12 -0800 Subject: [PATCH 66/72] docs for "audio" vocab --- extra/audio/audio-docs.factor | 43 +++++++++++++++++++++++++++++++++++ extra/audio/audio.factor | 1 + extra/audio/authors.txt | 1 + extra/audio/summary.txt | 1 + 4 files changed, 46 insertions(+) create mode 100644 extra/audio/audio-docs.factor create mode 100644 extra/audio/authors.txt create mode 100644 extra/audio/summary.txt diff --git a/extra/audio/audio-docs.factor b/extra/audio/audio-docs.factor new file mode 100644 index 0000000000..c08887e962 --- /dev/null +++ b/extra/audio/audio-docs.factor @@ -0,0 +1,43 @@ +! (c)2010 Joe Groff bsd license +USING: alien byte-arrays help.markup help.syntax kernel math +memory ; +IN: audio + +HELP: