\r
+ listener/plugin:\r
\r
+- word added >1 \r
- sidekick: still parsing too much\r
- errors don't always disappear\r
- console: wrong history\r
+++ /dev/null
-IN: scratchpad
-USE: hashtables
-USE: namespaces
-USE: oop
-USE: stack
-USE: test
-
-TRAITS: test-traits
-
-[ t ] [ <test-traits> test-traits? ] unit-test
-[ f ] [ "hello" test-traits? ] unit-test
-[ f ] [ <namespace> test-traits? ] unit-test
-
-GENERIC: foo
-
-M: test-traits foo drop 12 ;M
-
-TRAITS: another-test
-
-M: another-test foo drop 13 ;M
-
-[ 12 ] [ <test-traits> foo ] unit-test
-[ 13 ] [ <another-test> foo ] unit-test
-
-TRAITS: quux
-
-M: quux foo "foo" swap hash ;M
-
-[
- "Hi"
-] [
- <quux> [
- "Hi" "foo" set
- ] extend foo
-] unit-test
+++ /dev/null
-! :sidekick.parser=none:
-IN: oop
-
-USE: combinators
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: namespaces
-USE: parser
-USE: stack
-USE: strings
-USE: words
-
-SYMBOL: traits
-
-: traits-map ( type -- hash )
- #! The method map word property maps selector words to
- #! definitions.
- "traits-map" word-property ;
-
-: object-map ( obj -- hash )
- dup hashtable? [ traits swap hash ] [ drop f ] ifte ;
-
-: init-traits-map ( word -- )
- <namespace> "traits-map" set-word-property ;
-
-: no-method
- "No applicable method." throw ;
-
-: method ( traits selector -- quot )
- #! Execute the method with the traits object on the stack.
- over object-map hash* [ cdr ] [ [ no-method ] ] ifte* ;
-
-: constructor-word ( word -- word )
- word-name "<" swap ">" cat3 "in" get create ;
-
-: define-constructor ( word -- )
- #! <foo> where foo is a traits type creates a new instance
- #! of foo.
- [ constructor-word [ <namespace> ] ] keep
- traits-map [ traits pick set-hash ] cons append
- define-compound ;
-
-: predicate-word ( word -- word )
- word-name "?" cat2 "in" get create ;
-
-: define-predicate ( word -- )
- #! foo? where foo is a traits type tests if the top of stack
- #! is of this type.
- dup predicate-word swap
- [ object-map ] swap traits-map [ eq? ] cons append
- define-compound ;
-
-: TRAITS:
- #! TRAITS: foo creates a new traits type. Instances can be
- #! created with <foo>, and tested with foo?.
- CREATE
- dup define-symbol
- dup init-traits-map
- dup define-constructor
- define-predicate ; parsing
-
-: GENERIC:
- #! GENERIC: bar creates a generic word bar that calls the
- #! bar method on the traits object, with the traits object
- #! on the stack.
- CREATE
- dup unit [ car method call ] cons
- define-compound ; parsing
-
-: M: ( -- type generic [ ] )
- #! M: foo bar begins a definition of the bar generic word
- #! specialized to the foo type.
- scan-word scan-word f ; parsing
-
-: ;M ( type generic def -- )
- #! ;M ends a method definition.
- rot traits-map [ reverse put ] bind ; parsing
vocabularies get [
"!syntax" get "syntax" set
- "!syntax" off
"syntax" get [
cdr dup word? [
] ifte
] hash-each
] bind
+
+"!syntax" vocabularies get remove-hash
run-user-init ;
+: auto-inline-count 5 ;
[
warm-boot
garbage-collection
0 [ drop succ ] each-word unparse write " words" print
+! "Counting word usages..." print
+! tally-usages
+!
+! "Automatically inlining words called " write
+! auto-inline-count unparse write
+! " or less times..." print
+! auto-inline-count auto-inline
+
"Inferring stack effects..." print
0 [ unit try-infer [ succ ] when ] each-word
unparse write " words have a stack effect" print
#std-invoke [ linearize-alien ] "linearizer" set-word-property
+: alien-invoke ( ... returns library function parameters -- ... )
+ "alien-invoke cannot be interpreted." throw ;
+
+\ alien-invoke [ 4 | 0 ] "infer-effect" set-word-property
+
+\ alien-invoke [
+ os "win32" = #std-invoke #c-invoke ? infer-alien
+] "infer" set-word-property
+
global [
"libraries" get [ <namespace> "libraries" set ] unless
] bind
: set-hash* ( key table quot -- )
#! Apply the quotation to yield a new association list.
- over >r -rot dupd (hashcode) r> vector-nth swap call ;
- inline
+ >r
+ 2dup (hashcode)
+ r> pick >r
+ over >r
+ >r swap vector-nth r> call
+ r>
+ r> set-vector-nth ; inline
-! : set-hash ( value key table -- )
+: set-hash ( value key table -- )
#! Store the value in the hashtable. Either replaces an
#! existing value in the appropriate bucket, or adds a new
#! key/value pair.
-! [ set-assoc ] set-hash* ;
+ [ set-assoc ] set-hash* ;
: remove-hash ( key table -- )
#! Remove a value from a hashtable.
END-UNION
: SDL_WaitEvent ( event -- )
- "int" "sdl" "SDL_WaitEvent" [ "event*" ] c-invoke ;
+ "int" "sdl" "SDL_WaitEvent" [ "event*" ] alien-invoke ;
: SDL_PollEvent ( event -- ? )
- "bool" "sdl" "SDL_PollEvent" [ "event*" ] c-invoke ;
+ "bool" "sdl" "SDL_PollEvent" [ "event*" ] alien-invoke ;
: pixelColor ( surface x y color -- )
"void" "sdl-gfx" "pixelColor"
[ "surface*" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: hlineColor ( surface x1 x2 y color -- )
"void" "sdl-gfx" "hlineColor"
[ "surface*" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: vlineColor ( surface x y1 y2 color -- )
"void" "sdl-gfx" "vlineColor"
[ "surface*" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: rectangleColor ( surface x1 y1 x2 y2 color -- )
"void" "sdl-gfx" "rectangleColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: boxColor ( surface x1 y1 x2 y2 color -- )
"void" "sdl-gfx" "boxColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: lineColor ( surface x1 y1 x2 y2 color -- )
"void" "sdl-gfx" "lineColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: aalineColor ( surface x1 y1 x2 y2 color -- )
"void" "sdl-gfx" "aalineColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: circleColor ( surface x y r color -- )
"void" "sdl-gfx" "circleColor"
[ "surface*" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: aacircleColor ( surface x y r color -- )
"void" "sdl-gfx" "aacircleColor"
[ "surface*" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: filledCircleColor ( surface x y r color -- )
"void" "sdl-gfx" "filledCircleColor"
[ "surface*" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: ellipseColor ( surface x y rx ry color -- )
"void" "sdl-gfx" "ellipseColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: aaellipseColor ( surface x y rx ry color -- )
"void" "sdl-gfx" "aaellipseColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: filledEllipseColor ( surface x y rx ry color -- )
"void" "sdl-gfx" "filledEllipseColor"
[ "surface*" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: pieColor ( surface x y rad start end color -- )
"void" "sdl-gfx" "pieColor"
[ "surface*" "short" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: filledPieColor ( surface x y rad start end color -- )
"void" "sdl-gfx" "filledPieColor"
[ "surface*" "short" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: trigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
"void" "sdl-gfx" "trigonColor"
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: aatrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
"void" "sdl-gfx" "aatrigonColor"
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: filledTrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
"void" "sdl-gfx" "filledTrigonColor"
[ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
- c-invoke ;
+ alien-invoke ;
: characterColor ( surface x y c color -- )
"void" "sdl-gfx" "characterColor"
[ "surface*" "short" "short" "char" "uint" ]
- c-invoke ;
+ alien-invoke ;
: stringColor ( surface x y str color -- )
"void" "sdl-gfx" "stringColor"
[ "surface*" "short" "short" "char*" "uint" ]
- c-invoke ;
+ alien-invoke ;
: SDL_VideoInit ( driver-name flags -- )
"int" "sdl" "SDL_VideoInit"
- [ "char*" "int" ] c-invoke ;
+ [ "char*" "int" ] alien-invoke ;
: SDL_VideoQuit ( -- )
- "void" "sdl" "SDL_VideoQuit" [ ] c-invoke ;
+ "void" "sdl" "SDL_VideoQuit" [ ] alien-invoke ;
! SDL_VideoDriverName -- needs strings as out params.
: SDL_GetVideoSurface ( -- surface )
- "surface*" "sdl" "SDL_GetVideoSurface" [ ] c-invoke ;
+ "surface*" "sdl" "SDL_GetVideoSurface" [ ] alien-invoke ;
! SDL_GetVideoInfo needs C struct bitfield support
: SDL_VideoModeOK ( width height bpp flags -- )
"int" "sdl" "SDL_VideoModeOK"
- [ "int" "int" "int" "int" ] c-invoke ;
+ [ "int" "int" "int" "int" ] alien-invoke ;
! SDL_ListModes needs array of structs support
: SDL_SetVideoMode ( width height bpp flags -- )
"surface*" "sdl" "SDL_SetVideoMode"
- [ "int" "int" "int" "int" ] c-invoke ;
+ [ "int" "int" "int" "int" ] alien-invoke ;
! UpdateRects, UpdateRect
: SDL_Flip ( surface -- )
- "bool" "sdl" "SDL_Flip" [ "surface*" ] c-invoke ;
+ "bool" "sdl" "SDL_Flip" [ "surface*" ] alien-invoke ;
! SDL_SetGamma: float types
: SDL_FillRect ( surface rect color -- n )
#! If rect is null, fills entire surface.
"bool" "sdl" "SDL_FillRect"
- [ "surface*" "rect*" "uint" ] c-invoke ;
+ [ "surface*" "rect*" "uint" ] alien-invoke ;
: SDL_LockSurface ( surface -- )
- "bool" "sdl" "SDL_LockSurface" [ "surface*" ] c-invoke ;
+ "bool" "sdl" "SDL_LockSurface" [ "surface*" ] alien-invoke ;
: SDL_UnlockSurface ( surface -- )
- "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] c-invoke ;
+ "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-invoke ;
: SDL_MapRGB ( surface r g b -- )
"uint" "sdl" "SDL_MapRGB"
- [ "surface*" "uchar" "uchar" "uchar" ] c-invoke ;
+ [ "surface*" "uchar" "uchar" "uchar" ] alien-invoke ;
: SDL_WM_SetCaption ( title icon -- )
"void" "sdl" "SDL_WM_SetCaption"
- [ "char*" "char*" ] c-invoke ;
+ [ "char*" "char*" ] alien-invoke ;
: SDL_INIT_EVERYTHING HEX: 0000FFFF ;
: SDL_Init ( mode -- )
- "int" "sdl" "SDL_Init" [ "int" ] c-invoke ;
+ "int" "sdl" "SDL_Init" [ "int" ] alien-invoke ;
: SDL_GetError ( -- error )
- "char*" "sdl" "SDL_GetError" [ ] c-invoke ;
+ "char*" "sdl" "SDL_GetError" [ ] alien-invoke ;
: SDL_Quit ( -- )
- "void" "sdl" "SDL_Quit" [ ] c-invoke ;
+ "void" "sdl" "SDL_Quit" [ ] alien-invoke ;
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: words
+USE: generic
USE: inspector
USE: lists
USE: kernel
USE: stdio
USE: strings
USE: unparser
+USE: math
: word-uses? ( of in -- ? )
2dup = [
: words. ( vocab -- )
words . ;
+
+: usage+ ( key -- )
+ dup "usages" word-property
+ [ succ ] [ 1 ] ifte*
+ "usages" set-word-property ;
+
+GENERIC: count-usages ( quot -- )
+M: object count-usages drop ;
+M: word count-usages usage+ ;
+M: cons count-usages unswons count-usages count-usages ;
+
+: tally-usages ( -- )
+ [ f "usages" set-word-property ] each-word
+ [ word-parameter count-usages ] each-word ;
+
+: auto-inline ( count -- )
+ #! Automatically inline all words called less than a count
+ #! number of times.
+ [
+ 2dup "usages" word-property dup 0 ? >= [
+ t "inline" set-word-property
+ ] [
+ drop
+ ] ifte
+ ] each-word drop ;
: each-word ( quot -- )
#! Apply a quotation to each word in the image.
vocabs [ words [ swap dup >r call r> ] each ] each drop ;
+ inline
: (search) ( name vocab -- word )
vocab dup [ hash ] [ 2drop f ] ifte ;
projects / factor.git / commitdiff