kernel io.files bootstrap.image sequences io urls ;
IN: bootstrap.image.download
-: url URL" http://factorcode.org/images/latest/" ;
+CONSTANT: url URL" http://factorcode.org/images/latest/"
: download-checksums ( -- alist )
url "checksums.txt" >url derive-url http-get nip
CAIRO_STATUS_INVALID_STRIDE ;
TYPEDEF: int cairo_content_t
-: CAIRO_CONTENT_COLOR HEX: 1000 ;
-: CAIRO_CONTENT_ALPHA HEX: 2000 ;
-: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
+CONSTANT: CAIRO_CONTENT_COLOR HEX: 1000
+CONSTANT: CAIRO_CONTENT_ALPHA HEX: 2000
+CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000
TYPEDEF: void* cairo_write_func_t
: cairo-write-func ( quot -- callback )
= (line | code | heading | list | table | paragraph | nl)*
;EBNF
-: invalid-url "javascript:alert('Invalid URL in farkup');" ;
+CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');"
: check-url ( href -- href' )
{
: param ( name -- value )\r
params get at ;\r
\r
-: revalidate-url-key "__u" ;\r
+CONSTANT: revalidate-url-key "__u"\r
\r
: revalidate-url ( -- url/f )\r
revalidate-url-key param\r
furnace.auth.login.permits ;
IN: furnace.alloy
-: state-classes { session aside conversation permit } ; inline
+CONSTANT: state-classes { session aside conversation permit }
: init-furnace-tables ( -- )
state-classes ensure-tables
{ "post-data" "POST_DATA" FACTOR-BLOB }
} define-persistent
-: aside-id-key "__a" ;
+CONSTANT: aside-id-key "__a"
TUPLE: asides < server-state-manager ;
\r
PRIVATE>\r
\r
-: flashed-variables { description capabilities } ;\r
+CONSTANT: flashed-variables { description capabilities }\r
\r
: login-failed ( -- * )\r
"invalid username or password" validation-error\r
USING: furnace.auth.providers kernel ;\r
IN: furnace.auth.providers.null\r
\r
-TUPLE: no-users ;\r
-\r
-: no-users T{ no-users } ;\r
+SINGLETON: no-users\r
\r
M: no-users get-user 2drop f ;\r
\r
{ "session" "SESSION" BIG-INTEGER +not-null+ }
} define-persistent
-: conversation-id-key "__c" ;
+CONSTANT: conversation-id-key "__c"
TUPLE: conversations < server-state-manager ;
[ session set ] [ save-session-after ] bi
sessions get responder>> call-responder ;
-: session-id-key "__s" ;
+CONSTANT: session-id-key "__s"
: verify-session ( session -- session )
sessions get verify?>> [
[XML <input type="hidden" value=<-> name=<->/> XML]
] [ drop ] if ;
-: nested-forms-key "__n" ;
+CONSTANT: nested-forms-key "__n"
: request-params ( request -- assoc )
dup method>> {
SYMBOL: exit-continuation
-: exit-with ( value -- )
+: exit-with ( value -- * )
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )
: CHLOE:
scan parse-definition define-chloe-tag ; parsing
-: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
+CONSTANT: chloe-ns "http://factorcode.org/chloe/1.0"
: chloe-name? ( name -- ? )
url>> chloe-ns = ;
hashtables io.encodings.ascii generic parser classes.tuple words
words.symbol io io.files splitting namespaces math
compiler.units accessors classes.singleton classes.mixin
-io.encodings.iana ;
+io.encodings.iana fry ;
IN: io.encodings.8-bit
<PRIVATE
-: mappings {
+CONSTANT: mappings {
! encoding-name iana-name file-name
{ "latin1" "ISO_8859-1:1987" "8859-1" }
{ "latin2" "ISO_8859-2:1987" "8859-2" }
{ "windows-1252" "windows-1252" "CP1252" }
{ "ebcdic" "IBM037" "CP037" }
{ "mac-roman" "macintosh" "ROMAN" }
-} ;
+}
: encoding-file ( file-name -- stream )
- "vocab:io/encodings/8-bit/" swap ".TXT"
- 3append ;
+ "vocab:io/encodings/8-bit/" ".TXT" surround ;
: process-contents ( lines -- assoc )
[ "#" split1 drop ] map harvest
: byte>ch ( assoc -- array )
256 replacement-char <array>
- [ [ swapd set-nth ] curry assoc-each ] keep ;
+ [ '[ swap _ set-nth ] assoc-each ] keep ;
: ch>byte ( assoc -- newassoc )
[ swap ] assoc-map >hashtable ;
dup values [ try-dispose ] each\r
clear-assoc ;\r
\r
-: keep-logs 10 ;\r
+CONSTANT: keep-logs 10\r
\r
: ?delete-file ( path -- )\r
dup exists? [ delete-file ] [ drop ] if ;\r
first2 [ imaginary-part ] dip >rect 3array ;
! Zero
-: q0 { 0 0 } ;
+CONSTANT: q0 { 0 0 }
! Units
-: q1 { 1 0 } ;
-: qi { C{ 0 1 } 0 } ;
-: qj { 0 1 } ;
-: qk { 0 C{ 0 1 } } ;
+CONSTANT: q1 { 1 0 }
+CONSTANT: qi { C{ 0 1 } 0 }
+CONSTANT: qj { 0 1 }
+CONSTANT: qk { 0 C{ 0 1 } }
! Euler angles
BOOL bInheritHandle,
DWORD dwOptions ) ;
-: DUPLICATE_CLOSE_SOURCE 1 ;
-: DUPLICATE_SAME_ACCESS 2 ;
+CONSTANT: DUPLICATE_CLOSE_SOURCE 1
+CONSTANT: DUPLICATE_SAME_ACCESS 2
! FUNCTION: EncodePointer
! FUNCTION: EncodeSystemPointer
! Reserved Resource and Constant Definitions
-: ParentRelative 1 ;
-: CopyFromParent 0 ;
-: PointerWindow 0 ;
-: InputFocus 1 ;
-: PointerRoot 1 ;
-: AnyPropertyType 0 ;
-: AnyKey 0 ;
-: AnyButton 0 ;
-: AllTemporary 0 ;
-: CurrentTime 0 ;
-: NoSymbol 0 ;
+CONSTANT: ParentRelative 1
+CONSTANT: CopyFromParent 0
+CONSTANT: PointerWindow 0
+CONSTANT: InputFocus 1
+CONSTANT: PointerRoot 1
+CONSTANT: AnyPropertyType 0
+CONSTANT: AnyKey 0
+CONSTANT: AnyButton 0
+CONSTANT: AllTemporary 0
+CONSTANT: CurrentTime 0
+CONSTANT: NoSymbol 0
! Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer,
! state in various key-, mouse-, and button-related events.
! modifier names. Used to build a SetModifierMapping request or
! to read a GetModifierMapping request. These correspond to the
! masks defined above.
-: ShiftMapIndex 0 ;
-: LockMapIndex 1 ;
-: ControlMapIndex 2 ;
-: Mod1MapIndex 3 ;
-: Mod2MapIndex 4 ;
-: Mod3MapIndex 5 ;
-: Mod4MapIndex 6 ;
-: Mod5MapIndex 7 ;
+CONSTANT: ShiftMapIndex 0
+CONSTANT: LockMapIndex 1
+CONSTANT: ControlMapIndex 2
+CONSTANT: Mod1MapIndex 3
+CONSTANT: Mod2MapIndex 4
+CONSTANT: Mod3MapIndex 5
+CONSTANT: Mod4MapIndex 6
+CONSTANT: Mod5MapIndex 7
! button masks. Used in same manner as Key masks above. Not to be confused
! Notify modes
-: NotifyNormal 0 ;
-: NotifyGrab 1 ;
-: NotifyUngrab 2 ;
-: NotifyWhileGrabbed 3 ;
+CONSTANT: NotifyNormal 0
+CONSTANT: NotifyGrab 1
+CONSTANT: NotifyUngrab 2
+CONSTANT: NotifyWhileGrabbed 3
-: NotifyHint 1 ; ! for MotionNotify events
+CONSTANT: NotifyHint 1 ! for MotionNotify events
! Notify detail
-: NotifyAncestor 0 ;
-: NotifyVirtual 1 ;
-: NotifyInferior 2 ;
-: NotifyNonlinear 3 ;
-: NotifyNonlinearVirtual 4 ;
-: NotifyPointer 5 ;
-: NotifyPointerRoot 6 ;
-: NotifyDetailNone 7 ;
+CONSTANT: NotifyAncestor 0
+CONSTANT: NotifyVirtual 1
+CONSTANT: NotifyInferior 2
+CONSTANT: NotifyNonlinear 3
+CONSTANT: NotifyNonlinearVirtual 4
+CONSTANT: NotifyPointer 5
+CONSTANT: NotifyPointerRoot 6
+CONSTANT: NotifyDetailNone 7
! Visibility notify
-: VisibilityUnobscured 0 ;
-: VisibilityPartiallyObscured 1 ;
-: VisibilityFullyObscured 2 ;
+CONSTANT: VisibilityUnobscured 0
+CONSTANT: VisibilityPartiallyObscured 1
+CONSTANT: VisibilityFullyObscured 2
! Circulation request
-: PlaceOnTop 0 ;
-: PlaceOnBottom 1 ;
+CONSTANT: PlaceOnTop 0
+CONSTANT: PlaceOnBottom 1
! protocol families
-: FamilyInternet 0 ; ! IPv4
-: FamilyDECnet 1 ;
-: FamilyChaos 2 ;
-: FamilyInternet6 6 ; ! IPv6
+CONSTANT: FamilyInternet 0 ! IPv4
+CONSTANT: FamilyDECnet 1
+CONSTANT: FamilyChaos 2
+CONSTANT: FamilyInternet6 6 ! IPv6
! authentication families not tied to a specific protocol
-: FamilyServerInterpreted 5 ;
+CONSTANT: FamilyServerInterpreted 5
! Property notification
-: PropertyNewValue 0 ;
-: PropertyDelete 1 ;
+CONSTANT: PropertyNewValue 0
+CONSTANT: PropertyDelete 1
! Color Map notification
-: ColormapUninstalled 0 ;
-: ColormapInstalled 1 ;
+CONSTANT: ColormapUninstalled 0
+CONSTANT: ColormapInstalled 1
! GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes
-: GrabModeSync 0 ;
-: GrabModeAsync 1 ;
+CONSTANT: GrabModeSync 0
+CONSTANT: GrabModeAsync 1
! GrabPointer, GrabKeyboard reply status
-: GrabSuccess 0 ;
-: AlreadyGrabbed 1 ;
-: GrabInvalidTime 2 ;
-: GrabNotViewable 3 ;
-: GrabFrozen 4 ;
+CONSTANT: GrabSuccess 0
+CONSTANT: AlreadyGrabbed 1
+CONSTANT: GrabInvalidTime 2
+CONSTANT: GrabNotViewable 3
+CONSTANT: GrabFrozen 4
! AllowEvents modes
-: AsyncPointer 0 ;
-: SyncPointer 1 ;
-: ReplayPointer 2 ;
-: AsyncKeyboard 3 ;
-: SyncKeyboard 4 ;
-: ReplayKeyboard 5 ;
-: AsyncBoth 6 ;
-: SyncBoth 7 ;
+CONSTANT: AsyncPointer 0
+CONSTANT: SyncPointer 1
+CONSTANT: ReplayPointer 2
+CONSTANT: AsyncKeyboard 3
+CONSTANT: SyncKeyboard 4
+CONSTANT: ReplayKeyboard 5
+CONSTANT: AsyncBoth 6
+CONSTANT: SyncBoth 7
! Used in SetInputFocus, GetInputFocus
: RevertToNone ( -- n ) None ;
: RevertToPointerRoot ( -- n ) PointerRoot ;
-: RevertToParent 2 ;
+CONSTANT: RevertToParent 2
! *****************************************************************
! * ERROR CODES
! *****************************************************************
-: Success 0 ; ! everything's okay
-: BadRequest 1 ; ! bad request code
-: BadValue 2 ; ! int parameter out of range
-: BadWindow 3 ; ! parameter not a Window
-: BadPixmap 4 ; ! parameter not a Pixmap
-: BadAtom 5 ; ! parameter not an Atom
-: BadCursor 6 ; ! parameter not a Cursor
-: BadFont 7 ; ! parameter not a Font
-: BadMatch 8 ; ! parameter mismatch
-: BadDrawable 9 ; ! parameter not a Pixmap or Window
-: BadAccess 10 ; ! depending on context:
+CONSTANT: Success 0 ! everything's okay
+CONSTANT: BadRequest 1 ! bad request code
+CONSTANT: BadValue 2 ! int parameter out of range
+CONSTANT: BadWindow 3 ! parameter not a Window
+CONSTANT: BadPixmap 4 ! parameter not a Pixmap
+CONSTANT: BadAtom 5 ! parameter not an Atom
+CONSTANT: BadCursor 6 ! parameter not a Cursor
+CONSTANT: BadFont 7 ! parameter not a Font
+CONSTANT: BadMatch 8 ! parameter mismatch
+CONSTANT: BadDrawable 9 ! parameter not a Pixmap or Window
+CONSTANT: BadAccess 10 ! depending on context:
! - key/button already grabbed
! - attempt to free an illegal
! cmap entry
! color map entry.
! - attempt to modify the access control
! list from other than the local host.
-: BadAlloc 11 ; ! insufficient resources
-: BadColor 12 ; ! no such colormap
-: BadGC 13 ; ! parameter not a GC
-: BadIDChoice 14 ; ! choice not in range or already used
-: BadName 15 ; ! font or color name doesn't exist
-: BadLength 16 ; ! Request length incorrect
-: BadImplementation 17 ; ! server is defective
+CONSTANT: BadAlloc 11 ! insufficient resources
+CONSTANT: BadColor 12 ! no such colormap
+CONSTANT: BadGC 13 ! parameter not a GC
+CONSTANT: BadIDChoice 14 ! choice not in range or already used
+CONSTANT: BadName 15 ! font or color name doesn't exist
+CONSTANT: BadLength 16 ! Request length incorrect
+CONSTANT: BadImplementation 17 ! server is defective
-: FirstExtensionError 128 ;
-: LastExtensionError 255 ;
+CONSTANT: FirstExtensionError 128
+CONSTANT: LastExtensionError 255
! *****************************************************************
! * WINDOW DEFINITIONS
! Window classes used by CreateWindow
! Note that CopyFromParent is already defined as 0 above
-: InputOutput 1 ;
-: InputOnly 2 ;
+CONSTANT: InputOutput 1
+CONSTANT: InputOnly 2
! Used in CreateWindow for backing-store hint
-: NotUseful 0 ;
-: WhenMapped 1 ;
-: Always 2 ;
+CONSTANT: NotUseful 0
+CONSTANT: WhenMapped 1
+CONSTANT: Always 2
! Used in ChangeSaveSet
-: SetModeInsert 0 ;
-: SetModeDelete 1 ;
+CONSTANT: SetModeInsert 0
+CONSTANT: SetModeDelete 1
! Used in ChangeCloseDownMode
-: DestroyAll 0 ;
-: RetainPermanent 1 ;
-: RetainTemporary 2 ;
+CONSTANT: DestroyAll 0
+CONSTANT: RetainPermanent 1
+CONSTANT: RetainTemporary 2
! Window stacking method (in configureWindow)
-: Above 0 ;
-: Below 1 ;
-: TopIf 2 ;
-: BottomIf 3 ;
-: Opposite 4 ;
+CONSTANT: Above 0
+CONSTANT: Below 1
+CONSTANT: TopIf 2
+CONSTANT: BottomIf 3
+CONSTANT: Opposite 4
! Circulation direction
-: RaiseLowest 0 ;
-: LowerHighest 1 ;
+CONSTANT: RaiseLowest 0
+CONSTANT: LowerHighest 1
! Property modes
-: PropModeReplace 0 ;
-: PropModePrepend 1 ;
-: PropModeAppend 2 ;
+CONSTANT: PropModeReplace 0
+CONSTANT: PropModePrepend 1
+CONSTANT: PropModeAppend 2
! *****************************************************************
! * GRAPHICS DEFINITIONS
! LineStyle
-: LineSolid 0 ;
-: LineOnOffDash 1 ;
-: LineDoubleDash 2 ;
+CONSTANT: LineSolid 0
+CONSTANT: LineOnOffDash 1
+CONSTANT: LineDoubleDash 2
! capStyle
-: CapNotLast 0 ;
-: CapButt 1 ;
-: CapRound 2 ;
-: CapProjecting 3 ;
+CONSTANT: CapNotLast 0
+CONSTANT: CapButt 1
+CONSTANT: CapRound 2
+CONSTANT: CapProjecting 3
! joinStyle
-: JoinMiter 0 ;
-: JoinRound 1 ;
-: JoinBevel 2 ;
+CONSTANT: JoinMiter 0
+CONSTANT: JoinRound 1
+CONSTANT: JoinBevel 2
! fillStyle
-: FillSolid 0 ;
-: FillTiled 1 ;
-: FillStippled 2 ;
-: FillOpaqueStippled 3 ;
+CONSTANT: FillSolid 0
+CONSTANT: FillTiled 1
+CONSTANT: FillStippled 2
+CONSTANT: FillOpaqueStippled 3
! fillRule
-: EvenOddRule 0 ;
-: WindingRule 1 ;
+CONSTANT: EvenOddRule 0
+CONSTANT: WindingRule 1
! subwindow mode
-: ClipByChildren 0 ;
-: IncludeInferiors 1 ;
+CONSTANT: ClipByChildren 0
+CONSTANT: IncludeInferiors 1
! SetClipRectangles ordering
-: Unsorted 0 ;
-: YSorted 1 ;
-: YXSorted 2 ;
-: YXBanded 3 ;
+CONSTANT: Unsorted 0
+CONSTANT: YSorted 1
+CONSTANT: YXSorted 2
+CONSTANT: YXBanded 3
! CoordinateMode for drawing routines
-: CoordModeOrigin 0 ; ! relative to the origin
-: CoordModePrevious 1 ; ! relative to previous point
+CONSTANT: CoordModeOrigin 0 ! relative to the origin
+CONSTANT: CoordModePrevious 1 ! relative to previous point
! Polygon shapes
-: Complex 0 ; ! paths may intersect
-: Nonconvex 1 ; ! no paths intersect, but not convex
-: Convex 2 ; ! wholly convex
+CONSTANT: Complex 0 ! paths may intersect
+CONSTANT: Nonconvex 1 ! no paths intersect, but not convex
+CONSTANT: Convex 2 ! wholly convex
! Arc modes for PolyFillArc
-: ArcChord 0 ; ! join endpoints of arc
-: ArcPieSlice 1 ; ! join endpoints to center of arc
+CONSTANT: ArcChord 0 ! join endpoints of arc
+CONSTANT: ArcPieSlice 1 ! join endpoints to center of arc
! *****************************************************************
! * FONTS
! used in QueryFont -- draw direction
-: FontLeftToRight 0 ;
-: FontRightToLeft 1 ;
+CONSTANT: FontLeftToRight 0
+CONSTANT: FontRightToLeft 1
-: FontChange 255 ;
+CONSTANT: FontChange 255
! *****************************************************************
! * IMAGING
! ImageFormat -- PutImage, GetImage
-: XYBitmap 0 ; ! depth 1, XYFormat
-: XYPixmap 1 ; ! depth == drawable depth
-: ZPixmap 2 ; ! depth == drawable depth
+CONSTANT: XYBitmap 0 ! depth 1, XYFormat
+CONSTANT: XYPixmap 1 ! depth == drawable depth
+CONSTANT: ZPixmap 2 ! depth == drawable depth
! *****************************************************************
! * COLOR MAP STUFF
! For CreateColormap
-: AllocNone 0 ; ! create map with no entries
-: AllocAll 1 ; ! allocate entire map writeable
+CONSTANT: AllocNone 0 ! create map with no entries
+CONSTANT: AllocAll 1 ! allocate entire map writeable
! Flags used in StoreNamedColor, StoreColors
! QueryBestSize Class
-: CursorShape 0 ; ! largest size that can be displayed
-: TileShape 1 ; ! size tiled fastest
-: StippleShape 2 ; ! size stippled fastest
+CONSTANT: CursorShape 0 ! largest size that can be displayed
+CONSTANT: TileShape 1 ! size tiled fastest
+CONSTANT: StippleShape 2 ! size stippled fastest
! *****************************************************************
! * KEYBOARD/POINTER STUFF
! *****************************************************************
-: AutoRepeatModeOff 0 ;
-: AutoRepeatModeOn 1 ;
-: AutoRepeatModeDefault 2 ;
+CONSTANT: AutoRepeatModeOff 0
+CONSTANT: AutoRepeatModeOn 1
+CONSTANT: AutoRepeatModeDefault 2
-: LedModeOff 0 ;
-: LedModeOn 1 ;
+CONSTANT: LedModeOff 0
+CONSTANT: LedModeOn 1
! masks for ChangeKeyboardControl
: KBKey ( -- n ) 6 2^ ;
: KBAutoRepeatMode ( -- n ) 7 2^ ;
-: MappingSuccess 0 ;
-: MappingBusy 1 ;
-: MappingFailed 2 ;
+CONSTANT: MappingSuccess 0
+CONSTANT: MappingBusy 1
+CONSTANT: MappingFailed 2
-: MappingModifier 0 ;
-: MappingKeyboard 1 ;
-: MappingPointer 2 ;
+CONSTANT: MappingModifier 0
+CONSTANT: MappingKeyboard 1
+CONSTANT: MappingPointer 2
! *****************************************************************
! * SCREEN SAVER STUFF
! *****************************************************************
-: DontPreferBlanking 0 ;
-: PreferBlanking 1 ;
-: DefaultBlanking 2 ;
+CONSTANT: DontPreferBlanking 0
+CONSTANT: PreferBlanking 1
+CONSTANT: DefaultBlanking 2
-: DisableScreenSaver 0 ;
-: DisableScreenInterval 0 ;
+CONSTANT: DisableScreenSaver 0
+CONSTANT: DisableScreenInterval 0
-: DontAllowExposures 0 ;
-: AllowExposures 1 ;
-: DefaultExposures 2 ;
+CONSTANT: DontAllowExposures 0
+CONSTANT: AllowExposures 1
+CONSTANT: DefaultExposures 2
! for ForceScreenSaver
-: ScreenSaverReset 0 ;
-: ScreenSaverActive 1 ;
+CONSTANT: ScreenSaverReset 0
+CONSTANT: ScreenSaverActive 1
! *****************************************************************
! * HOSTS AND CONNECTIONS
! for ChangeHosts
-: HostInsert 0 ;
-: HostDelete 1 ;
+CONSTANT: HostInsert 0
+CONSTANT: HostDelete 1
! for ChangeAccessControl
-: EnableAccess 1 ;
-: DisableAccess 0 ;
+CONSTANT: EnableAccess 1
+CONSTANT: DisableAccess 0
! Display classes used in opening the connection
! Note that the statically allocated ones are even numbered and the
! dynamically changeable ones are odd numbered
-: StaticGray 0 ;
-: GrayScale 1 ;
-: StaticColor 2 ;
-: PseudoColor 3 ;
-: TrueColor 4 ;
-: DirectColor 5 ;
+CONSTANT: StaticGray 0
+CONSTANT: GrayScale 1
+CONSTANT: StaticColor 2
+CONSTANT: PseudoColor 3
+CONSTANT: TrueColor 4
+CONSTANT: DirectColor 5
! Byte order used in imageByteOrder and bitmapBitOrder
-: LSBFirst 0 ;
-: MSBFirst 1 ;
+CONSTANT: LSBFirst 0
+CONSTANT: MSBFirst 1
! *****************************************************************
! * EXTENDED WINDOW MANAGER HINTS
LIBRARY: glx
! Visual Config Attributes (glXGetConfig, glXGetFBConfigAttrib)
-: GLX_USE_GL 1 ; ! support GLX rendering
-: GLX_BUFFER_SIZE 2 ; ! depth of the color buffer
-: GLX_LEVEL 3 ; ! level in plane stacking
-: GLX_RGBA 4 ; ! true if RGBA mode
-: GLX_DOUBLEBUFFER 5 ; ! double buffering supported
-: GLX_STEREO 6 ; ! stereo buffering supported
-: GLX_AUX_BUFFERS 7 ; ! number of aux buffers
-: GLX_RED_SIZE 8 ; ! number of red component bits
-: GLX_GREEN_SIZE 9 ; ! number of green component bits
-: GLX_BLUE_SIZE 10 ; ! number of blue component bits
-: GLX_ALPHA_SIZE 11 ; ! number of alpha component bits
-: GLX_DEPTH_SIZE 12 ; ! number of depth bits
-: GLX_STENCIL_SIZE 13 ; ! number of stencil bits
-: GLX_ACCUM_RED_SIZE 14 ; ! number of red accum bits
-: GLX_ACCUM_GREEN_SIZE 15 ; ! number of green accum bits
-: GLX_ACCUM_BLUE_SIZE 16 ; ! number of blue accum bits
-: GLX_ACCUM_ALPHA_SIZE 17 ; ! number of alpha accum bits
+CONSTANT: GLX_USE_GL 1 ! support GLX rendering
+CONSTANT: GLX_BUFFER_SIZE 2 ! depth of the color buffer
+CONSTANT: GLX_LEVEL 3 ! level in plane stacking
+CONSTANT: GLX_RGBA 4 ! true if RGBA mode
+CONSTANT: GLX_DOUBLEBUFFER 5 ! double buffering supported
+CONSTANT: GLX_STEREO 6 ! stereo buffering supported
+CONSTANT: GLX_AUX_BUFFERS 7 ! number of aux buffers
+CONSTANT: GLX_RED_SIZE 8 ! number of red component bits
+CONSTANT: GLX_GREEN_SIZE 9 ! number of green component bits
+CONSTANT: GLX_BLUE_SIZE 10 ! number of blue component bits
+CONSTANT: GLX_ALPHA_SIZE 11 ! number of alpha component bits
+CONSTANT: GLX_DEPTH_SIZE 12 ! number of depth bits
+CONSTANT: GLX_STENCIL_SIZE 13 ! number of stencil bits
+CONSTANT: GLX_ACCUM_RED_SIZE 14 ! number of red accum bits
+CONSTANT: GLX_ACCUM_GREEN_SIZE 15 ! number of green accum bits
+CONSTANT: GLX_ACCUM_BLUE_SIZE 16 ! number of blue accum bits
+CONSTANT: GLX_ACCUM_ALPHA_SIZE 17 ! number of alpha accum bits
TYPEDEF: XID GLXContextID
TYPEDEF: XID GLXPixmap
XNResourceClass over 0 XCreateIC
[ "XCreateIC() failed" throw ] unless* ;
-: buf-size 100 ;
+CONSTANT: buf-size 100
SYMBOL: keybuf
SYMBOL: keysym
io.files io.encodings.binary xml.state ;
IN: xml.entities
-: entities-out
+CONSTANT: entities-out
H{
{ CHAR: < "<" }
{ CHAR: > ">" }
{ CHAR: & "&" }
- } ;
+ }
-: quoted-entities-out
+CONSTANT: quoted-entities-out
H{
{ CHAR: & "&" }
{ CHAR: ' "'" }
{ CHAR: " """ }
{ CHAR: < "<" }
- } ;
+ }
: escape-string-by ( str table -- escaped )
#! Convert <, >, &, ' and " to HTML entities.
: escape-quoted-string ( str -- newstr )
quoted-entities-out escape-string-by ;
-: entities
+CONSTANT: entities
H{
{ "lt" CHAR: < }
{ "gt" CHAR: > }
{ "amp" CHAR: & }
{ "apos" CHAR: ' }
{ "quot" CHAR: " }
- } ;
+ }
: with-entities ( entities quot -- )
[ swap extra-entities set call ] with-scope ; inline
TUPLE: attr-w/< < xml-error-at ;
-: attr-w/< ( value -- * )
+: attr-w/< ( -- * )
\ attr-w/< xml-error-at throw ;
M: attr-w/< summary
TUPLE: text-w/]]> < xml-error-at ;
-: text-w/]]> ( text -- * )
+: text-w/]]> ( -- * )
\ text-w/]]> xml-error-at throw ;
M: text-w/]]> summary
IN: 24-game
SYMBOL: commands
-: nop ;
+: nop ( -- ) ;
: do-something ( a b -- c ) { + - * } amb-execute ;
: maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
: some-rots ( a b c -- a b c )
! placing them on the stack, and applying the operations
! +, -, * and rot as many times as we wish.
-: nop ;
+: nop ( -- ) ;
: do-something ( a b -- c )
{ + - * } amb-execute ;
] sigma
] sigma ;
-: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ;
+CONSTANT: words { 24-from-1 24-from-2 24-from-3 24-from-4 }
: backtrack-benchmark ( -- )
words [ reset-memoized ] each
CONSTANT: initial-seed 42
CONSTANT: line-length 60
-USE: math.private
-
: random ( seed -- n seed )
>float IA * IC + IM mod [ IM /f ] keep ; inline
CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"
-: IUB
+CONSTANT: IUB
{
{ CHAR: a 0.27 }
{ CHAR: c 0.12 }
{ CHAR: V 0.02 }
{ CHAR: W 0.02 }
{ CHAR: Y 0.02 }
- } ; inline
+ }
-: homo-sapiens
+CONSTANT: homo-sapiens
{
{ CHAR: a 0.3029549426680 }
{ CHAR: c 0.1979883004921 }
{ CHAR: g 0.1975473066391 }
{ CHAR: t 0.3015094502008 }
- } ; inline
+ }
: make-cumulative ( freq -- chars floats )
dup keys >byte-array
IN: benchmark.raytracer
! parameters
-: light
- #! Normalized { -1 -3 2 }.
+
+! Normalized { -1 -3 2 }.
+CONSTANT: light
double-array{
-0.2672612419124244
-0.8017837257372732
0.5345224838248488
- } ; inline
+ }
CONSTANT: oversampling 4
SYMBOL: port-promise
SYMBOL: server
-: number-of-requests 1000 ;
+CONSTANT: number-of-requests 1000
: server-addr ( -- addr )
"127.0.0.1" port-promise get ?promise <inet4> ;
compiler.cfg.optimizer fry ;
IN: galois-talk
-: galois-slides
+CONSTANT: galois-slides
{
{ $slide "Factor!"
{ $url "http://factorcode.org" }
"Factor has many cool things that I didn't talk about"
"Questions?"
}
-} ;
+}
: galois-talk ( -- ) galois-slides slides-window ;
: hat-switch? ( {usage-page,usage} -- ? )
{ 1 HEX: 39 } = ; inline
-: pov-values
+CONSTANT: pov-values
{
pov-up pov-up-right pov-right pov-down-right
pov-down pov-down-left pov-left pov-up-left
pov-neutral
- } ; inline
+ }
: button-value ( value -- f/(0,1] )
IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
compiler.cfg.optimizer fry ;
IN: google-tech-talk
-: google-slides
+CONSTANT: google-slides
{
{ $slide "Factor!"
{ $url "http://factorcode.org" }
"Put your prejudices aside and give it a shot!"
}
{ $slide "Questions?" }
-} ;
+}
: google-talk ( -- ) google-slides slides-window ;
! Setup and running objects
! ======================================
-: irc-port 6667 ; ! Default irc port
+CONSTANT: irc-port 6667 ! Default irc port
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
\r
: write-color ( str color -- )\r
foreground associate format ;\r
-: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;\r
-: dark-green T{ rgba f 0.0 0.5 0.0 1 } ;\r
-: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ;\r
+CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }\r
+CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }\r
+CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }\r
\r
: dot-or-parens ( string -- string )\r
[ "." ]\r
combinators math.parser assocs threads ;
IN: joystick-demo
-: SIZE { 151 151 } ;
-: INDICATOR-SIZE { 4 4 } ;
+CONSTANT: SIZE { 151 151 }
+CONSTANT: INDICATOR-SIZE { 4 4 }
: FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: axis-gadget < gadget indicator z-indicator pov ;
: indicator-polygon ( -- polygon )
{ 0 0 } INDICATOR-SIZE (rect-polygon) ;
-: pov-polygons
+CONSTANT: pov-polygons
V{
{ pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } }
{ pov-up { { 70 65 } { 75 60 } { 80 65 } } }
{ pov-down-left { { 67 90 } { 60 90 } { 60 83 } } }
{ pov-left { { 65 70 } { 60 75 } { 65 80 } } }
{ pov-up-left { { 67 60 } { 60 60 } { 60 67 } } }
- } ;
+ }
: <indicator-gadget> ( color -- indicator )
indicator-polygon <polygon-gadget> ;
ui.gadgets.borders ui.gestures ;
IN: key-caps
-: key-locations H{
+CONSTANT: key-locations H{
{ key-escape { { 0 0 } { 10 10 } } }
{ key-f1 { { 20 0 } { 10 10 } } }
{ key-keypad-0 { { 190 55 } { 20 10 } } }
{ key-keypad-. { { 210 55 } { 10 10 } } }
-} ;
+}
-: KEYBOARD-SIZE { 230 65 } ;
+CONSTANT: KEYBOARD-SIZE { 230 65 }
: FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: key-caps-gadget < gadget keys alarm ;
set-alien-float alien-float
} ;
-: trivial-defs
+: trivial-defs ( -- seq )
{
[ drop ] [ 2array ]
[ bitand ]
USING: arrays kernel xml-rpc ;
IN: lisppaste
-: url "http://www.common-lisp.net:8185/RPC2" ;
+CONSTANT: url "http://www.common-lisp.net:8185/RPC2"
: channels ( -- seq )
{ } "listchannels" url invoke-method ;
: ?prepare-build-machine ( -- )
builds/factor exists? [ prepare-build-machine ] unless ;
-: load-everything-vocabs-file "load-everything-vocabs" ;
-: load-everything-errors-file "load-everything-errors" ;
+CONSTANT: load-everything-vocabs-file "load-everything-vocabs"
+CONSTANT: load-everything-errors-file "load-everything-errors"
-: test-all-vocabs-file "test-all-vocabs" ;
-: test-all-errors-file "test-all-errors" ;
+CONSTANT: test-all-vocabs-file "test-all-vocabs"
+CONSTANT: test-all-errors-file "test-all-errors"
-: help-lint-vocabs-file "help-lint-vocabs" ;
-: help-lint-errors-file "help-lint-errors" ;
+CONSTANT: help-lint-vocabs-file "help-lint-vocabs"
+CONSTANT: help-lint-errors-file "help-lint-errors"
-: boot-time-file "boot-time" ;
-: load-time-file "load-time" ;
-: compiler-errors-file "compiler-errors" ;
-: test-time-file "test-time" ;
-: help-lint-time-file "help-lint-time" ;
-: benchmark-time-file "benchmark-time" ;
-: html-help-time-file "html-help-time" ;
+CONSTANT: boot-time-file "boot-time"
+CONSTANT: load-time-file "load-time"
+CONSTANT: compiler-errors-file "compiler-errors"
+CONSTANT: test-time-file "test-time"
+CONSTANT: help-lint-time-file "help-lint-time"
+CONSTANT: benchmark-time-file "benchmark-time"
+CONSTANT: html-help-time-file "html-help-time"
-: benchmarks-file "benchmarks" ;
+CONSTANT: benchmarks-file "benchmarks"
SYMBOL: status
CONSTANT: gamma-g6 5.15
-: gamma-p6
+CONSTANT: gamma-p6
{
2.50662827563479526904 225.525584619175212544 -268.295973841304927459
80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556
- } ; inline
+ }
: gamma-z ( x n -- seq )
[ + recip ] with map 1.0 0 pick set-nth ;
math.order math.geometry.rect ;
IN: maze
-: line-width 8 ;
+CONSTANT: line-width 8
SYMBOL: visited
sequences kernel sequences parser memoize ;
IN: minneapolis-talk
-: minneapolis-slides
+CONSTANT: minneapolis-slides
{
{ $slide "What is Factor?"
"Dynamically typed, stack language"
"Mailing list: factor-talk@lists.sf.net"
}
{ $slide "Questions?" }
-} ;
+}
: minneapolis-talk ( -- ) minneapolis-slides slides-window ;
+++ /dev/null
-- how to create a small module\r
-- editor integration\r
-- presentations\r
-- module system\r
-- copy and paste factoring, inverse\r
-- help system\r
-- tetris\r
-- memoization\r
-- editing inspector demo\r
-- dynamic scope, lexical scope\r
-\r
-Factor: contradictions?\r
------------------------\r
-\r
-Have our cake and eat it too\r
-\r
-Research -vs- practical\r
-High level -vs- fast\r
-Interactive -vs- deployment\r
-\r
-Factor from 10,000 feet\r
------------------------\r
-\r
-word: named function\r
-vocabulary: module\r
-quotation: anonymous function\r
-classes, objects, etc.\r
-\r
-The stack\r
----------\r
-\r
-- Stack -vs- applicative\r
-- Pass by reference, dynamically typed\r
-- Stack languages: you can omit names where they're not needed\r
-- More compositional style\r
-- If you need to name things for clarity, you can:\r
- lexical vars, dynamic vars, sequences, assocs, objects...\r
-\r
-Functional programming\r
-----------------------\r
-\r
-Quotations\r
-Curry\r
-Continuations\r
-\r
-Object-oriented programming\r
----------------------------\r
-\r
-Generic words: sort of like open classes\r
-Tuple reshaping\r
-Editing inspector\r
-\r
-Meta programming\r
-----------------\r
-\r
-Simple, orthogonal core\r
-\r
-Why use a stack at all?\r
------------------------\r
-\r
-Nice idioms: 10 days ago\r
-Copy and paste factoring\r
-Easy meta-programming\r
-Sequence operations correspond to functional operations:\r
-- curry is adding at the front\r
-- compose is append\r
-\r
-UI\r
---\r
-\r
-Written in Factor\r
-renders with OpenGL\r
-Windows, X11, Cocoa backends\r
-You can call Windows, X11, Cocoa APIs directly\r
-OpenGL 2.1 shaders, OpenAL 3D audio...\r
-\r
-Tools\r
------\r
-\r
-Edit\r
-Usages\r
-Profiler\r
-Easy to make your own tools\r
-\r
-Implementation\r
---------------\r
-\r
-Two compilers\r
-Generational garbage collector\r
-Non-blocking I/O\r
-\r
-Hands on\r
---------\r
-\r
-Community\r
----------\r
-\r
-Factor started in 2003\r
-About a dozen contributors\r
-Handful of "core contributors"\r
-Web site: http://factorcode.org\r
-IRC: #concatenative on irc.freenode.net\r
-Mailing list: factor-talk@lists.sf.net\r
-\r
-C library interface\r
--------------------\r
-\r
-Efficient\r
-No need to write C code\r
-Supports floats, structs, unions, ...\r
-Function pointers, callbacks\r
-Here is an example\r
-\r
-TerminateProcess\r
-\r
-process-handle TerminateProcess\r
TUPLE: nehe2-gadget < gadget ;
-: width 256 ;
-: height 256 ;
+CONSTANT: width 256
+CONSTANT: height 256
: <nehe2-gadget> ( -- gadget )
nehe2-gadget new-gadget ;
TUPLE: nehe3-gadget < gadget ;
-: width 256 ;
-: height 256 ;
+CONSTANT: width 256
+CONSTANT: height 256
: <nehe3-gadget> ( -- gadget )
nehe3-gadget new-gadget ;
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
-: width 256 ;
-: height 256 ;
+CONSTANT: width 256
+CONSTANT: height 256
: redraw-interval ( -- dt ) 10 milliseconds ;
: <nehe4-gadget> ( -- gadget )
IN: nehe.5\r
\r
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;\r
-: width 256 ;\r
-: height 256 ;\r
+CONSTANT: width 256\r
+CONSTANT: height 256\r
: redraw-interval ( -- dt ) 10 milliseconds ;\r
\r
: <nehe5-gadget> ( -- gadget )\r
: $tetris ( element -- )
drop [ <default-tetris> <tetris-gadget> gadget. ] ($block) ;
-: otug-slides
+CONSTANT: otug-slides
{
{ $slide "Factor!"
{ $url "http://factorcode.org" }
"Factor has many cool things that I didn't talk about"
"Questions?"
}
-} ;
+}
: otug-talk ( -- ) otug-slides slides-window ;
parser accessors colors ;
IN: slides
-: stylesheet
+CONSTANT: stylesheet
H{
{ default-span-style
H{
H{ { table-gap { 10 20 } } }
}
{ bullet "\u0000b7" }
- } ;
+ }
: $title ( string -- )
[ H{ { font "sans-serif" } { font-size 48 } } format ] ($block) ;
compiler.cfg.optimizer fry ;
IN: vpri-talk
-: vpri-slides
+CONSTANT: vpri-slides
{
{ $slide "Factor!"
{ $url "http://factorcode.org" }
"Factor has many cool things that I didn't talk about"
"Questions?"
}
-} ;
+}
: vpri-talk ( -- ) vpri-slides slides-window ;
first3 <result>
] map ;
-: yahoo-url ( -- str )
- URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" ;
+CONSTANT: yahoo-url URL" http://search.yahooapis.com/WebSearchService/V1/webSearch"
:: param ( search url name quot -- search url )
search url search quot call
"similar_ok" [ similar-ok>> ] bool-param
nip ;
-: factor-id
- "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" ;
+CONSTANT: factor-id "fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-"
: <search> ( query -- search )
search new
+++ /dev/null
-! Based on http://research.sun.com/people/mario/java_benchmarking/
-! Ported by Factor by Slava Pestov
-!
-! Based on original version written in BCPL by Dr Martin Richards
-! in 1981 at Cambridge University Computer Laboratory, England
-! Java version: Copyright (C) 1995 Sun Microsystems, Inc.
-! by Jonathan Gibbons.
-! Outer loop added 8/7/96 by Alex Jacoby
-USING: values kernel accessors math math.bitwise sequences
-arrays combinators fry locals ;
-IN: benchmark.richards
-
-! Packets
-TUPLE: packet link id kind a1 a2 ;
-
-: BUFSIZE 4 ; inline
-
-: <packet> ( link id kind -- packet )
- packet new
- swap >>kind
- swap >>id
- swap >>link
- 0 >>a1
- BUFSIZE 0 <array> >>a2 ;
-
-: last-packet ( packet -- last )
- dup link>> [ last-packet ] [ ] ?if ;
-
-: append-to ( packet list -- packet )
- [ f >>link ] dip
- [ tuck last-packet >>link drop ] when* ;
-
-! Tasks
-: I_IDLE 1 ; inline
-: I_WORK 2 ; inline
-: I_HANDLERA 3 ; inline
-: I_HANDLERB 4 ; inline
-: I_DEVA 5 ; inline
-: I_DEVB 6 ; inline
-
-! Packet types
-: K_DEV 1000 ; inline
-: K_WORK 1001 ; inline
-
-: PKTBIT 1 ; inline
-: WAITBIT 2 ; inline
-: HOLDBIT 4 ; inline
-
-: S_RUN 0 ; inline
-: S_RUNPKT ( -- n ) { PKTBIT } flags ; inline
-: S_WAIT ( -- n ) { WAITBIT } flags ; inline
-: S_WAITPKT ( -- n ) { WAITBIT PKTBIT } flags ; inline
-: S_HOLD ( -- n ) { HOLDBIT } flags ; inline
-: S_HOLDPKT ( -- n ) { HOLDBIT PKTBIT } flags ; inline
-: S_HOLDWAIT ( -- n ) { HOLDBIT WAITBIT } flags ; inline
-: S_HOLDWAITPKT ( -- n ) { HOLDBIT WAITBIT PKTBIT } flags ; inline
-
-: task-tab-size 10 ; inline
-
-VALUE: task-tab
-VALUE: task-list
-VALUE: tracing
-VALUE: hold-count
-VALUE: qpkt-count
-
-TUPLE: task link id pri wkq state ;
-
-: new-task ( id pri wkq state class -- task )
- new
- swap >>state
- swap >>wkq
- swap >>pri
- swap >>id
- task-list >>link
- dup to: task-list
- dup dup id>> task-tab set-nth ; inline
-
-GENERIC: fn ( packet task -- task )
-
-: state-on ( task flag -- task )
- '[ _ bitor ] change-state ; inline
-
-: state-off ( task flag -- task )
- '[ _ bitnot bitand ] change-state ; inline
-
-: wait-task ( task -- task )
- WAITBIT state-on ;
-
-: hold ( task -- task )
- hold-count 1+ to: hold-count
- HOLDBIT state-on
- link>> ;
-
-: highest-priority ( t1 t2 -- t1/t2 )
- [ [ pri>> ] bi@ > ] most ;
-
-: find-tcb ( i -- task )
- task-tab nth [ "Bad task" throw ] unless* ;
-
-: release ( task i -- task )
- find-tcb HOLDBIT state-off highest-priority ;
-
-:: qpkt ( task pkt -- task )
- [let | t [ pkt id>> find-tcb ] |
- t [
- qpkt-count 1+ to: qpkt-count
- f pkt (>>link)
- task id>> pkt (>>id)
- t wkq>> [
- pkt t wkq>> append-to t (>>wkq)
- task
- ] [
- pkt t (>>wkq)
- t PKTBIT state-on drop
- t task highest-priority
- ] if
- ] [ task ] if
- ] ;
-
-: schedule-waitpkt ( task -- task pkt )
- dup wkq>>
- 2dup link>> >>wkq drop
- 2dup S_RUNPKT S_RUN ? >>state drop ; inline
-
-: schedule-run ( task pkt -- task )
- swap fn ; inline
-
-: schedule-wait ( task -- task )
- link>> ; inline
-
-: (schedule) ( task -- )
- [
- dup state>> {
- { S_WAITPKT [ schedule-waitpkt schedule-run (schedule) ] }
- { S_RUN [ f schedule-run (schedule) ] }
- { S_RUNPKT [ f schedule-run (schedule) ] }
- { S_WAIT [ schedule-wait (schedule) ] }
- { S_HOLD [ schedule-wait (schedule) ] }
- { S_HOLDPKT [ schedule-wait (schedule) ] }
- { S_HOLDWAIT [ schedule-wait (schedule) ] }
- { S_HOLDWAITPKT [ schedule-wait (schedule) ] }
- [ 2drop ]
- } case
- ] when* ;
-
-: schedule ( -- )
- task-list (schedule) ;
-
-! Device task
-TUPLE: device-task < task v1 ;
-
-: <device-task> ( id pri wkq -- task )
- dup S_WAITPKT S_WAIT ? device-task new-task ;
-
-M:: device-task fn ( pkt task -- task )
- pkt [
- task dup v1>>
- [ wait-task ]
- [ [ f ] change-v1 swap qpkt ] if
- ] [ pkt task (>>v1) task hold ] if ;
-
-TUPLE: handler-task < task workpkts devpkts ;
-
-: <handler-task> ( id pri wkq -- task )
- dup S_WAITPKT S_WAIT ? handler-task new-task ;
-
-M:: handler-task fn ( pkt task -- task )
- pkt [
- task over kind>> K_WORK =
- [ [ append-to ] change-workpkts ]
- [ [ append-to ] change-devpkts ]
- if drop
- ] when*
-
- task workpkts>> [
- [let* | devpkt [ task devpkts>> ]
- workpkt [ task workpkts>> ]
- count [ workpkt a1>> ] |
- count BUFSIZE > [
- workpkt link>> task (>>workpkts)
- task workpkt qpkt
- ] [
- devpkt [
- devpkt link>> task (>>devpkts)
- count workpkt a2>> nth devpkt (>>a1)
- count 1+ workpkt (>>a1)
- task devpkt qpkt
- ] [
- task wait-task
- ] if
- ] if
- ]
- ] [ task wait-task ] if ;
-
-! Idle task
-TUPLE: idle-task < task { v1 fixnum } { v2 fixnum } ;
-
-: <idle-task> ( i a1 a2 -- task )
- [ 0 f S_RUN idle-task new-task ] 2dip
- [ >>v1 ] [ >>v2 ] bi* ;
-
-M: idle-task fn ( pkt task -- task )
- nip
- [ 1- ] change-v2
- dup v2>> 0 = [ hold ] [
- dup v1>> 1 bitand 0 = [
- [ -1 shift ] change-v1
- I_DEVA release
- ] [
- [ -1 shift HEX: d008 bitor ] change-v1
- I_DEVB release
- ] if
- ] if ;
-
-! Work task
-TUPLE: work-task < task { handler fixnum } { n fixnum } ;
-
-: <work-task> ( id pri w -- work-task )
- dup S_WAITPKT S_WAIT ? work-task new-task
- I_HANDLERA >>handler
- 0 >>n ;
-
-M:: work-task fn ( pkt task -- task )
- pkt [
- task [ I_HANDLERA = I_HANDLERB I_HANDLERA ? ] change-handler drop
- task handler>> pkt (>>id)
- 0 pkt (>>a1)
- BUFSIZE [| i |
- task [ 1+ ] change-n drop
- task n>> 26 > [ 1 task (>>n) ] when
- task n>> 1 - CHAR: A + i pkt a2>> set-nth
- ] each
- task pkt qpkt
- ] [ task wait-task ] if ;
-
-! Main
-: init ( -- )
- task-tab-size f <array> to: task-tab
- f to: tracing
- 0 to: hold-count
- 0 to: qpkt-count ;
-
-: start ( -- )
- I_IDLE 1 10000 <idle-task> drop
-
- I_WORK 1000
- f 0 K_WORK <packet> 0 K_WORK <packet>
- <work-task> drop
-
- I_HANDLERA 2000
- f I_DEVA K_DEV <packet>
- I_DEVA K_DEV <packet>
- I_DEVA K_DEV <packet>
- <handler-task> drop
-
- I_HANDLERB 3000
- f I_DEVB K_DEV <packet>
- I_DEVB K_DEV <packet>
- I_DEVB K_DEV <packet>
- <handler-task> drop
-
- I_DEVA 4000 f <device-task> drop
- I_DEVB 4000 f <device-task> drop ;
-
-: check ( -- )
- qpkt-count 23246 assert=
- hold-count 9297 assert= ;
-
-: run ( -- )
- init
- start
- schedule check ;
+++ /dev/null
-USING: kernel namespaces db.sql sequences math ;
-IN: db.sql.tests
-
-! TUPLE: person name age ;
-: insert-1
- { insert
- {
- { table "person" }
- { columns "name" "age" }
- { values "erg" 26 }
- }
- } ;
-
-: update-1
- { update "person"
- { set { "name" "erg" }
- { "age" 6 } }
- { where { "age" 6 } }
- } ;
-
-: select-1
- { select
- { columns
- "branchno"
- { count "staffno" as "mycount" }
- { sum "salary" as "mysum" } }
- { from "staff" "lol" }
- { where
- { "salary" > all
- { select
- { columns "salary" }
- { from "staff" }
- { where { "branchno" = "b003" } }
- }
- }
- { "branchno" > 3 } }
- { group-by "branchno" "lol2" }
- { having { count "staffno" > 1 } }
- { order-by "branchno" }
- { offset 40 }
- { limit 20 }
- } ;
+++ /dev/null
-USING: kernel parser quotations classes.tuple words math.order
-nmake namespaces sequences arrays combinators
-prettyprint strings math.parser math symbols db ;
-IN: db.sql
-
-SYMBOLS: insert update delete select distinct columns from as
-where group-by having order-by limit offset is-null desc all
-any count avg table values ;
-
-: input-spec, ( obj -- ) 1, ;
-: output-spec, ( obj -- ) 2, ;
-: input, ( obj -- ) 3, ;
-: output, ( obj -- ) 4, ;
-
-DEFER: sql%
-
-: (sql-interleave) ( seq sep -- )
- [ sql% ] curry [ sql% ] interleave ;
-
-: sql-interleave ( seq str sep -- )
- swap sql% (sql-interleave) ;
-
-: sql-function, ( seq function -- )
- sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
-
-: sql-where, ( seq -- )
- [
- [ second 0, ]
- [ first 0, ]
- [ third 1, \ ? 0, ] tri
- ] each ;
-
-HOOK: sql-create db ( object -- )
-M: db sql-create ( object -- )
- drop
- "create table" sql% ;
-
-HOOK: sql-drop db ( object -- )
-M: db sql-drop ( object -- )
- drop
- "drop table" sql% ;
-
-HOOK: sql-insert db ( object -- )
-M: db sql-insert ( object -- )
- drop
- "insert into" sql% ;
-
-HOOK: sql-update db ( object -- )
-M: db sql-update ( object -- )
- drop
- "update" sql% ;
-
-HOOK: sql-delete db ( object -- )
-M: db sql-delete ( object -- )
- drop
- "delete" sql% ;
-
-HOOK: sql-select db ( object -- )
-M: db sql-select ( object -- )
- "select" sql% "," (sql-interleave) ;
-
-HOOK: sql-columns db ( object -- )
-M: db sql-columns ( object -- )
- "," (sql-interleave) ;
-
-HOOK: sql-from db ( object -- )
-M: db sql-from ( object -- )
- "from" "," sql-interleave ;
-
-HOOK: sql-where db ( object -- )
-M: db sql-where ( object -- )
- "where" 0, sql-where, ;
-
-HOOK: sql-group-by db ( object -- )
-M: db sql-group-by ( object -- )
- "group by" "," sql-interleave ;
-
-HOOK: sql-having db ( object -- )
-M: db sql-having ( object -- )
- "having" "," sql-interleave ;
-
-HOOK: sql-order-by db ( object -- )
-M: db sql-order-by ( object -- )
- "order by" "," sql-interleave ;
-
-HOOK: sql-offset db ( object -- )
-M: db sql-offset ( object -- )
- "offset" sql% sql% ;
-
-HOOK: sql-limit db ( object -- )
-M: db sql-limit ( object -- )
- "limit" sql% sql% ;
-
-! GENERIC: sql-subselect db ( object -- )
-! M: db sql-subselectselect ( object -- )
- ! "(select" sql% sql% ")" sql% ;
-
-HOOK: sql-table db ( object -- )
-M: db sql-table ( object -- )
- sql% ;
-
-HOOK: sql-set db ( object -- )
-M: db sql-set ( object -- )
- "set" "," sql-interleave ;
-
-HOOK: sql-values db ( object -- )
-M: db sql-values ( object -- )
- "values(" sql% "," (sql-interleave) ")" sql% ;
-
-HOOK: sql-count db ( object -- )
-M: db sql-count ( object -- )
- "count" sql-function, ;
-
-HOOK: sql-sum db ( object -- )
-M: db sql-sum ( object -- )
- "sum" sql-function, ;
-
-HOOK: sql-avg db ( object -- )
-M: db sql-avg ( object -- )
- "avg" sql-function, ;
-
-HOOK: sql-min db ( object -- )
-M: db sql-min ( object -- )
- "min" sql-function, ;
-
-HOOK: sql-max db ( object -- )
-M: db sql-max ( object -- )
- "max" sql-function, ;
-
-: sql-array% ( array -- )
- unclip
- {
- { \ create [ sql-create ] }
- { \ drop [ sql-drop ] }
- { \ insert [ sql-insert ] }
- { \ update [ sql-update ] }
- { \ delete [ sql-delete ] }
- { \ select [ sql-select ] }
- { \ columns [ sql-columns ] }
- { \ from [ sql-from ] }
- { \ where [ sql-where ] }
- { \ group-by [ sql-group-by ] }
- { \ having [ sql-having ] }
- { \ order-by [ sql-order-by ] }
- { \ offset [ sql-offset ] }
- { \ limit [ sql-limit ] }
- { \ table [ sql-table ] }
- { \ set [ sql-set ] }
- { \ values [ sql-values ] }
- { \ count [ sql-count ] }
- { \ sum [ sql-sum ] }
- { \ avg [ sql-avg ] }
- { \ min [ sql-min ] }
- { \ max [ sql-max ] }
- [ sql% [ sql% ] each ]
- } case ;
-
-ERROR: no-sql-match ;
-: sql% ( obj -- )
- {
- { [ dup string? ] [ 0, ] }
- { [ dup array? ] [ sql-array% ] }
- { [ dup number? ] [ number>string sql% ] }
- { [ dup symbol? ] [ unparse sql% ] }
- { [ dup word? ] [ unparse sql% ] }
- { [ dup quotation? ] [ call ] }
- [ no-sql-match ]
- } cond ;
-
-: parse-sql ( obj -- sql in-spec out-spec in out )
- [ [ sql% ] each ] { { } { } { } } nmake
- [ " " join ] 2dip ;
projects / factor.git / commitdiff