Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
a5d6c38439
|
|
@ -737,6 +737,7 @@ define-builtin
|
||||||
{ "resize-bit-array" "bit-arrays" }
|
{ "resize-bit-array" "bit-arrays" }
|
||||||
{ "resize-float-array" "float-arrays" }
|
{ "resize-float-array" "float-arrays" }
|
||||||
{ "dll-valid?" "alien" }
|
{ "dll-valid?" "alien" }
|
||||||
|
{ "unimplemented" "kernel.private" }
|
||||||
}
|
}
|
||||||
dup length [ >r first2 r> make-primitive ] 2each
|
dup length [ >r first2 r> make-primitive ] 2each
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -594,3 +594,5 @@ set-primitive-effect
|
||||||
\ dll-valid? { object } { object } <effect> set-primitive-effect
|
\ dll-valid? { object } { object } <effect> set-primitive-effect
|
||||||
|
|
||||||
\ modify-code-heap { array object } { } <effect> set-primitive-effect
|
\ modify-code-heap { array object } { } <effect> set-primitive-effect
|
||||||
|
|
||||||
|
\ unimplemented { } { } <effect> set-primitive-effect
|
||||||
|
|
|
||||||
|
|
@ -7,14 +7,15 @@ ARTICLE: "file-streams" "Reading and writing files"
|
||||||
{ $subsection <file-reader> }
|
{ $subsection <file-reader> }
|
||||||
{ $subsection <file-writer> }
|
{ $subsection <file-writer> }
|
||||||
{ $subsection <file-appender> }
|
{ $subsection <file-appender> }
|
||||||
|
"Reading and writing the entire contents of a file; this is only recommended for smaller files:"
|
||||||
|
{ $subsection file-contents }
|
||||||
|
{ $subsection set-file-contents }
|
||||||
|
{ $subsection file-lines }
|
||||||
|
{ $subsection set-file-lines }
|
||||||
"Utility combinators:"
|
"Utility combinators:"
|
||||||
{ $subsection with-file-reader }
|
{ $subsection with-file-reader }
|
||||||
{ $subsection with-file-writer }
|
{ $subsection with-file-writer }
|
||||||
{ $subsection with-file-appender }
|
{ $subsection with-file-appender } ;
|
||||||
{ $subsection set-file-contents }
|
|
||||||
{ $subsection file-contents }
|
|
||||||
{ $subsection set-file-lines }
|
|
||||||
{ $subsection file-lines } ;
|
|
||||||
|
|
||||||
ARTICLE: "pathnames" "Pathname manipulation"
|
ARTICLE: "pathnames" "Pathname manipulation"
|
||||||
"Pathname manipulation:"
|
"Pathname manipulation:"
|
||||||
|
|
|
||||||
|
|
@ -108,3 +108,12 @@ IN: kernel.tests
|
||||||
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
|
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
|
||||||
|
|
||||||
[ loop ] must-fail
|
[ loop ] must-fail
|
||||||
|
|
||||||
|
! Discovered on Windows
|
||||||
|
: total-failure-1 "" [ ] map unimplemented ;
|
||||||
|
|
||||||
|
[ total-failure-1 ] must-fail
|
||||||
|
|
||||||
|
: total-failure-2 [ ] (call) unimplemented ;
|
||||||
|
|
||||||
|
[ total-failure-2 ] must-fail
|
||||||
|
|
|
||||||
|
|
@ -284,10 +284,6 @@ HELP: use
|
||||||
HELP: in
|
HELP: in
|
||||||
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
|
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
|
||||||
|
|
||||||
HELP: shadow-warnings
|
|
||||||
{ $values { "vocab" "an assoc mapping strings to words" } { "vocabs" "a sequence of assocs" } }
|
|
||||||
{ $description "Tests if any keys in " { $snippet "vocab" } " shadow keys in the elements of " { $snippet "vocabs" } ", and if so, prints a warning message. These warning messages can be disabled by setting " { $link parser-notes } " to " { $link f } "." } ;
|
|
||||||
|
|
||||||
HELP: (use+)
|
HELP: (use+)
|
||||||
{ $values { "vocab" "an assoc mapping strings to words" } }
|
{ $values { "vocab" "an assoc mapping strings to words" } }
|
||||||
{ $description "Adds an assoc at the front of the search path." }
|
{ $description "Adds an assoc at the front of the search path." }
|
||||||
|
|
|
||||||
|
|
@ -191,22 +191,8 @@ SYMBOL: in
|
||||||
: word/vocab% ( word -- )
|
: word/vocab% ( word -- )
|
||||||
"(" % dup word-vocabulary % " " % word-name % ")" % ;
|
"(" % dup word-vocabulary % " " % word-name % ")" % ;
|
||||||
|
|
||||||
: shadow-warning ( new old -- )
|
|
||||||
2dup eq? [
|
|
||||||
2drop
|
|
||||||
] [
|
|
||||||
[ word/vocab% " shadowed by " % word/vocab% ] "" make
|
|
||||||
note.
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: shadow-warnings ( vocab vocabs -- )
|
|
||||||
[
|
|
||||||
swapd assoc-stack dup
|
|
||||||
[ shadow-warning ] [ 2drop ] if
|
|
||||||
] curry assoc-each ;
|
|
||||||
|
|
||||||
: (use+) ( vocab -- )
|
: (use+) ( vocab -- )
|
||||||
vocab-words use get 2dup shadow-warnings push ;
|
vocab-words use get push ;
|
||||||
|
|
||||||
: use+ ( vocab -- )
|
: use+ ( vocab -- )
|
||||||
load-vocab (use+) ;
|
load-vocab (use+) ;
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
IN: io.windows.launcher.nt.tests
|
IN: io.windows.launcher.nt.tests
|
||||||
USING: io.launcher tools.test calendar accessors
|
USING: io.launcher tools.test calendar accessors
|
||||||
namespaces kernel system arrays io io.files io.encodings.ascii
|
namespaces kernel system arrays io io.files io.encodings.ascii
|
||||||
sequences parser assocs hashtables ;
|
sequences parser assocs hashtables math ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
<process>
|
<process>
|
||||||
|
|
@ -129,3 +129,14 @@ sequences parser assocs hashtables ;
|
||||||
|
|
||||||
"HOME" swap at "XXX" =
|
"HOME" swap at "XXX" =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
2 [
|
||||||
|
[ ] [
|
||||||
|
<process>
|
||||||
|
"cmd.exe /c dir" >>command
|
||||||
|
"dir.txt" temp-file >>stdout
|
||||||
|
try-process
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ "dir.txt" temp-file delete-file ] unit-test
|
||||||
|
] times
|
||||||
|
|
|
||||||
|
|
@ -39,7 +39,7 @@ IN: io.windows.nt.launcher
|
||||||
create-mode
|
create-mode
|
||||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||||
f ! template file
|
f ! template file
|
||||||
CreateFile dup invalid-handle? dup close-later ;
|
CreateFile dup invalid-handle? dup close-always ;
|
||||||
|
|
||||||
: set-inherit ( handle ? -- )
|
: set-inherit ( handle ? -- )
|
||||||
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
||||||
|
|
|
||||||
|
|
@ -70,6 +70,9 @@ PREDICATE: method-body < word
|
||||||
M: method-body stack-effect
|
M: method-body stack-effect
|
||||||
"multi-method" word-prop method-generic stack-effect ;
|
"multi-method" word-prop method-generic stack-effect ;
|
||||||
|
|
||||||
|
M: method-body crossref?
|
||||||
|
drop t ;
|
||||||
|
|
||||||
: method-word-name ( classes generic -- string )
|
: method-word-name ( classes generic -- string )
|
||||||
[
|
[
|
||||||
word-name %
|
word-name %
|
||||||
|
|
|
||||||
|
|
@ -68,6 +68,29 @@ IN: newfx
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: delete ( seq elt -- seq ) over sequences:delete ;
|
||||||
|
: delete-from ( elt seq -- seq ) tuck sequences:delete ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: deleted ( seq elt -- ) swap sequences:delete ;
|
||||||
|
: deleted-from ( elt seq -- ) sequences:delete ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: remove ( seq obj -- seq ) swap sequences:remove ;
|
||||||
|
: remove-from ( obj seq -- seq ) sequences:remove ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: subset-of ( quot seq -- seq ) swap subset ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: map-over ( quot seq -- seq ) swap map ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
! A note about the 'mutate' qualifier. Other words also technically mutate
|
! A note about the 'mutate' qualifier. Other words also technically mutate
|
||||||
! their primary object. However, the 'mutate' qualifier is supposed to
|
! their primary object. However, the 'mutate' qualifier is supposed to
|
||||||
! indicate that this is the main objective of the word, as a side effect.
|
! indicate that this is the main objective of the word, as a side effect.
|
||||||
|
|
@ -173,7 +173,7 @@ HELP: range-pattern
|
||||||
"of characters separated with a dash (-) represents the "
|
"of characters separated with a dash (-) represents the "
|
||||||
"range of characters from the first to the second, inclusive."
|
"range of characters from the first to the second, inclusive."
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
|
{ $example "USING: peg peg.parsers prettyprint strings ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
|
||||||
{ $example "USING: peg peg.parsers prettyprint ;" "\"0\" \"^0-9\" range-pattern parse ." "f" }
|
{ $example "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse ." "f" }
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
|
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sequences strings namespaces math assocs shuffle
|
USING: kernel sequences strings namespaces math assocs shuffle
|
||||||
vectors arrays combinators.lib math.parser match
|
vectors arrays combinators.lib math.parser
|
||||||
unicode.categories sequences.deep peg peg.private
|
unicode.categories sequences.deep peg peg.private
|
||||||
peg.search math.ranges words memoize ;
|
peg.search math.ranges words memoize ;
|
||||||
IN: peg.parsers
|
IN: peg.parsers
|
||||||
|
|
|
||||||
|
|
@ -104,8 +104,8 @@ HELP: semantic
|
||||||
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
|
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
|
||||||
"the AST produced by 'p1' on the stack returns true." }
|
"the AST produced by 'p1' on the stack returns true." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" }
|
{ $example "USING: kernel math peg prettyprint ;" "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse ." "f" }
|
||||||
{ $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" }
|
{ $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast ." "67" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: ensure
|
HELP: ensure
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2007, 2008 Chris Double.
|
! Copyright (C) 2007, 2008 Chris Double.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sequences strings fry namespaces math assocs shuffle
|
USING: kernel sequences strings fry namespaces math assocs shuffle
|
||||||
vectors arrays combinators.lib math.parser match
|
vectors arrays combinators.lib math.parser
|
||||||
unicode.categories sequences.lib compiler.units parser
|
unicode.categories sequences.lib compiler.units parser
|
||||||
words quotations effects memoize accessors locals effects splitting ;
|
words quotations effects memoize accessors locals effects splitting ;
|
||||||
IN: peg
|
IN: peg
|
||||||
|
|
@ -241,7 +241,7 @@ GENERIC: (compile) ( parser -- quot )
|
||||||
: compiled-parse ( state word -- result )
|
: compiled-parse ( state word -- result )
|
||||||
swap [ execute ] with-packrat ; inline
|
swap [ execute ] with-packrat ; inline
|
||||||
|
|
||||||
: parse ( state parser -- result )
|
: parse ( input parser -- result )
|
||||||
dup word? [ compile ] unless compiled-parse ;
|
dup word? [ compile ] unless compiled-parse ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
@ -265,8 +265,6 @@ SYMBOL: id
|
||||||
|
|
||||||
TUPLE: token-parser symbol ;
|
TUPLE: token-parser symbol ;
|
||||||
|
|
||||||
MATCH-VARS: ?token ;
|
|
||||||
|
|
||||||
: parse-token ( input string -- result )
|
: parse-token ( input string -- result )
|
||||||
#! Parse the string, returning a parse result
|
#! Parse the string, returning a parse result
|
||||||
dup >r ?head-slice [
|
dup >r ?head-slice [
|
||||||
|
|
@ -388,9 +386,6 @@ M: optional-parser (compile) ( parser -- quot )
|
||||||
p1>> compiled-parser 1quotation '[ @ check-optional ] ;
|
p1>> compiled-parser 1quotation '[ @ check-optional ] ;
|
||||||
|
|
||||||
TUPLE: semantic-parser p1 quot ;
|
TUPLE: semantic-parser p1 quot ;
|
||||||
MATCH-VARS: ?quot ;
|
|
||||||
|
|
||||||
MATCH-VARS: ?parser ;
|
|
||||||
|
|
||||||
: check-semantic ( result quot -- result )
|
: check-semantic ( result quot -- result )
|
||||||
over [
|
over [
|
||||||
|
|
@ -421,8 +416,6 @@ M: ensure-not-parser (compile) ( parser -- quot )
|
||||||
|
|
||||||
TUPLE: action-parser p1 quot ;
|
TUPLE: action-parser p1 quot ;
|
||||||
|
|
||||||
MATCH-VARS: ?action ;
|
|
||||||
|
|
||||||
: check-action ( result quot -- result )
|
: check-action ( result quot -- result )
|
||||||
over [
|
over [
|
||||||
over ast>> swap call >>ast
|
over ast>> swap call >>ast
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,22 @@
|
||||||
|
|
||||||
|
USING: kernel sequences ;
|
||||||
|
|
||||||
|
IN: processing.color
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: rgba red green blue alpha ;
|
||||||
|
|
||||||
|
C: <rgba> rgba
|
||||||
|
|
||||||
|
: <rgb> ( r g b -- rgba ) 1 <rgba> ;
|
||||||
|
|
||||||
|
: <gray> ( gray -- rgba ) dup dup 1 <rgba> ;
|
||||||
|
|
||||||
|
: {rgb} ( seq -- rgba ) first3 <rgb> ;
|
||||||
|
|
||||||
|
! : hex>rgba ( hex -- rgba )
|
||||||
|
|
||||||
|
! : set-gl-color ( color -- )
|
||||||
|
! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,80 @@
|
||||||
|
|
||||||
|
USING: kernel namespaces combinators
|
||||||
|
ui.gestures qualified accessors ui.gadgets.frame-buffer ;
|
||||||
|
|
||||||
|
IN: processing.gadget
|
||||||
|
|
||||||
|
QUALIFIED: ui.gadgets
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: processing-gadget button-down button-up key-down key-up ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: set-gadget-delegate ( tuple gadget -- tuple )
|
||||||
|
over ui.gadgets:set-gadget-delegate ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: <processing-gadget> ( -- gadget )
|
||||||
|
processing-gadget construct-empty
|
||||||
|
<frame-buffer> set-gadget-delegate ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
SYMBOL: mouse-pressed-value
|
||||||
|
SYMBOL: key-pressed-value
|
||||||
|
|
||||||
|
SYMBOL: button-value
|
||||||
|
SYMBOL: key-value
|
||||||
|
|
||||||
|
: key-pressed? ( -- ? ) key-pressed-value get ;
|
||||||
|
: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
|
||||||
|
|
||||||
|
: key ( -- key ) key-value get ;
|
||||||
|
: button ( -- val ) button-value get ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
M: processing-gadget handle-gesture* ( gadget gesture delegate -- ? )
|
||||||
|
rot drop swap ! delegate gesture
|
||||||
|
{
|
||||||
|
{
|
||||||
|
[ dup key-down? ]
|
||||||
|
[
|
||||||
|
key-down-sym key-value set
|
||||||
|
key-pressed-value on
|
||||||
|
key-down>> dup [ call ] [ drop ] if
|
||||||
|
t
|
||||||
|
]
|
||||||
|
}
|
||||||
|
{
|
||||||
|
[ dup key-up? ]
|
||||||
|
[
|
||||||
|
key-pressed-value off
|
||||||
|
drop
|
||||||
|
key-up>> dup [ call ] [ drop ] if
|
||||||
|
t
|
||||||
|
] }
|
||||||
|
{
|
||||||
|
[ dup button-down? ]
|
||||||
|
[
|
||||||
|
button-down-# button-value set
|
||||||
|
mouse-pressed-value on
|
||||||
|
button-down>> dup [ call ] [ drop ] if
|
||||||
|
t
|
||||||
|
]
|
||||||
|
}
|
||||||
|
{
|
||||||
|
[ dup button-up? ]
|
||||||
|
[
|
||||||
|
mouse-pressed-value off
|
||||||
|
drop
|
||||||
|
button-up>> dup [ call ] [ drop ] if
|
||||||
|
t
|
||||||
|
]
|
||||||
|
}
|
||||||
|
{ [ t ] [ 2drop t ] }
|
||||||
|
}
|
||||||
|
cond ;
|
||||||
|
|
@ -0,0 +1,477 @@
|
||||||
|
|
||||||
|
USING: kernel namespaces sequences combinators arrays threads
|
||||||
|
|
||||||
|
math
|
||||||
|
math.libm
|
||||||
|
math.vectors
|
||||||
|
math.ranges
|
||||||
|
math.constants
|
||||||
|
math.functions
|
||||||
|
|
||||||
|
ui
|
||||||
|
ui.gadgets
|
||||||
|
|
||||||
|
random accessors multi-methods
|
||||||
|
combinators.cleave
|
||||||
|
vars locals
|
||||||
|
|
||||||
|
newfx
|
||||||
|
|
||||||
|
processing
|
||||||
|
processing.gadget
|
||||||
|
processing.color ;
|
||||||
|
|
||||||
|
IN: processing.gallery.bubble-chamber
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
|
||||||
|
|
||||||
|
: 1random ( b -- num ) 0 swap 2random ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: dim ( -- dim ) 1000 ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
VAR: collision-theta
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
VAR: boom
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
VARS: particles muons quarks hadrons axions ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: good-colors ( -- seq )
|
||||||
|
{
|
||||||
|
T{ rgba f 0.23 0.14 0.17 1 }
|
||||||
|
T{ rgba f 0.23 0.14 0.15 1 }
|
||||||
|
T{ rgba f 0.21 0.14 0.15 1 }
|
||||||
|
T{ rgba f 0.51 0.39 0.33 1 }
|
||||||
|
T{ rgba f 0.49 0.33 0.20 1 }
|
||||||
|
T{ rgba f 0.55 0.45 0.32 1 }
|
||||||
|
T{ rgba f 0.69 0.63 0.51 1 }
|
||||||
|
T{ rgba f 0.64 0.39 0.18 1 }
|
||||||
|
T{ rgba f 0.73 0.42 0.20 1 }
|
||||||
|
T{ rgba f 0.71 0.45 0.29 1 }
|
||||||
|
T{ rgba f 0.79 0.45 0.22 1 }
|
||||||
|
T{ rgba f 0.82 0.56 0.34 1 }
|
||||||
|
T{ rgba f 0.88 0.72 0.49 1 }
|
||||||
|
T{ rgba f 0.85 0.69 0.40 1 }
|
||||||
|
T{ rgba f 0.96 0.92 0.75 1 }
|
||||||
|
T{ rgba f 0.99 0.98 0.87 1 }
|
||||||
|
T{ rgba f 0.85 0.82 0.69 1 }
|
||||||
|
T{ rgba f 0.99 0.98 0.87 1 }
|
||||||
|
T{ rgba f 0.82 0.82 0.79 1 }
|
||||||
|
T{ rgba f 0.65 0.69 0.67 1 }
|
||||||
|
T{ rgba f 0.53 0.60 0.55 1 }
|
||||||
|
T{ rgba f 0.57 0.53 0.68 1 }
|
||||||
|
T{ rgba f 0.47 0.42 0.56 1 }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
: good-color ( i -- color ) good-colors nth-of ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: x>> ( particle -- x ) pos>> first ;
|
||||||
|
: y>> ( particle -- x ) pos>> second ;
|
||||||
|
|
||||||
|
: >>x ( particle x -- particle ) over y>> 2array >>pos ;
|
||||||
|
: >>y ( particle y -- particle ) over x>> swap 2array >>pos ;
|
||||||
|
|
||||||
|
: x x>> ;
|
||||||
|
: y y>> ;
|
||||||
|
|
||||||
|
: v+y ( seq y -- seq ) >r first2 r> + 2array ;
|
||||||
|
: v-y ( seq y -- seq ) >r first2 r> - 2array ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: out-of-bounds? ( particle -- particle ? )
|
||||||
|
dup
|
||||||
|
{ [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
|
||||||
|
or or or ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
GENERIC: collide ( particle -- )
|
||||||
|
GENERIC: move ( particle -- )
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ;
|
||||||
|
|
||||||
|
: <muon> ( -- muon )
|
||||||
|
muon construct-empty
|
||||||
|
0 0 2array >>pos
|
||||||
|
0 >>speed
|
||||||
|
0 >>speed-d
|
||||||
|
0 >>theta
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
0 0 0 1 <rgba> >>myc
|
||||||
|
0 0 0 1 <rgba> >>mya ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: collide { muon }
|
||||||
|
|
||||||
|
dim 2 / dup 2array >>pos
|
||||||
|
2 32 [a,b] random >>speed
|
||||||
|
0.0001 0.001 2random >>speed-d
|
||||||
|
|
||||||
|
collision-theta> -0.1 0.1 2random + >>theta
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
[ dup theta-dd>> abs 0.001 < ]
|
||||||
|
[ -0.1 0.1 2random >>theta-dd ]
|
||||||
|
[ ]
|
||||||
|
while
|
||||||
|
|
||||||
|
dup theta>> pi +
|
||||||
|
2 pi * /
|
||||||
|
good-colors length 1 - *
|
||||||
|
[ ] [ good-colors length >= ] [ 0 < ] tri or
|
||||||
|
[ drop ]
|
||||||
|
[
|
||||||
|
[ good-color >>myc ]
|
||||||
|
[ good-colors length swap - 1 - good-color >>mya ]
|
||||||
|
bi
|
||||||
|
]
|
||||||
|
if
|
||||||
|
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: move { muon }
|
||||||
|
|
||||||
|
dup myc>> 0.16 >>alpha stroke
|
||||||
|
dup pos>> point
|
||||||
|
|
||||||
|
dup mya>> 0.16 >>alpha stroke
|
||||||
|
dup pos>> first2 >r dim swap - r> 2array point
|
||||||
|
|
||||||
|
dup
|
||||||
|
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
||||||
|
move-by
|
||||||
|
|
||||||
|
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
|
||||||
|
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
||||||
|
[ ] [ speed>> ] [ speed-d>> ] tri - >>speed
|
||||||
|
|
||||||
|
out-of-bounds?
|
||||||
|
[ collide ]
|
||||||
|
[ drop ]
|
||||||
|
if ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: quark pos vel speed theta speed-d theta-d theta-dd myc ;
|
||||||
|
|
||||||
|
: <quark> ( -- quark )
|
||||||
|
quark construct-empty
|
||||||
|
0 0 2array >>pos
|
||||||
|
0 0 2array >>vel
|
||||||
|
0 >>speed
|
||||||
|
0 >>speed-d
|
||||||
|
0 >>theta
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
0 0 0 1 <rgba> >>myc ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: collide { quark }
|
||||||
|
|
||||||
|
dim 2 / dup 2array >>pos
|
||||||
|
collision-theta> -0.11 0.11 2random + >>theta
|
||||||
|
0.5 3.0 2random >>speed
|
||||||
|
|
||||||
|
0.996 1.001 2random >>speed-d
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
[ dup theta-dd>> abs 0.00001 < ]
|
||||||
|
[ -0.001 0.001 2random >>theta-dd ]
|
||||||
|
[ ]
|
||||||
|
while
|
||||||
|
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: move { quark }
|
||||||
|
|
||||||
|
dup myc>> 0.13 >>alpha stroke
|
||||||
|
dup pos>> point
|
||||||
|
|
||||||
|
dup pos>> first2 >r dim swap - r> 2array point
|
||||||
|
|
||||||
|
[ ] [ vel>> ] bi move-by
|
||||||
|
|
||||||
|
dup
|
||||||
|
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
||||||
|
>>vel
|
||||||
|
|
||||||
|
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
|
||||||
|
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
||||||
|
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
||||||
|
|
||||||
|
1000 random 997 >
|
||||||
|
[
|
||||||
|
dup speed>> neg >>speed
|
||||||
|
2 over speed-d>> - >>speed-d
|
||||||
|
]
|
||||||
|
when
|
||||||
|
|
||||||
|
out-of-bounds?
|
||||||
|
[ collide ]
|
||||||
|
[ drop ]
|
||||||
|
if ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: hadron pos vel speed theta speed-d theta-d theta-dd myc ;
|
||||||
|
|
||||||
|
: <hadron> ( -- hadron )
|
||||||
|
hadron construct-empty
|
||||||
|
0 0 2array >>pos
|
||||||
|
0 0 2array >>vel
|
||||||
|
0 >>speed
|
||||||
|
0 >>speed-d
|
||||||
|
0 >>theta
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
0 0 0 1 <rgba> >>myc ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: collide { hadron }
|
||||||
|
|
||||||
|
dim 2 / dup 2array >>pos
|
||||||
|
2 pi * 1random >>theta
|
||||||
|
0.5 3.5 2random >>speed
|
||||||
|
|
||||||
|
0.996 1.001 2random >>speed-d
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
[ dup theta-dd>> abs 0.00001 < ]
|
||||||
|
[ -0.001 0.001 2random >>theta-dd ]
|
||||||
|
[ ]
|
||||||
|
while
|
||||||
|
|
||||||
|
0 1 0 <rgb> >>myc
|
||||||
|
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: move { hadron }
|
||||||
|
|
||||||
|
{ 1 0.11 } stroke
|
||||||
|
dup pos>> 1 v-y point
|
||||||
|
|
||||||
|
{ 0 0.11 } stroke
|
||||||
|
dup pos>> 1 v+y point
|
||||||
|
|
||||||
|
dup vel>> move-by
|
||||||
|
|
||||||
|
dup
|
||||||
|
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
||||||
|
>>vel
|
||||||
|
|
||||||
|
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
|
||||||
|
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
||||||
|
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
||||||
|
|
||||||
|
1000 random 997 >
|
||||||
|
[
|
||||||
|
1.0 >>speed-d
|
||||||
|
0.00001 >>theta-dd
|
||||||
|
|
||||||
|
100 random 70 >
|
||||||
|
[
|
||||||
|
dim 2 / dup 2array >>pos
|
||||||
|
dup collide
|
||||||
|
]
|
||||||
|
when
|
||||||
|
]
|
||||||
|
when
|
||||||
|
|
||||||
|
out-of-bounds?
|
||||||
|
[ collide ]
|
||||||
|
[ drop ]
|
||||||
|
if ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: axion pos vel speed theta speed-d theta-d theta-dd ;
|
||||||
|
|
||||||
|
: <axion> ( -- axion )
|
||||||
|
axion construct-empty
|
||||||
|
0 0 2array >>pos
|
||||||
|
0 0 2array >>vel
|
||||||
|
0 >>speed
|
||||||
|
0 >>speed-d
|
||||||
|
0 >>theta
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: collide { axion }
|
||||||
|
|
||||||
|
dim 2 / dup 2array >>pos
|
||||||
|
2 pi * 1random >>theta
|
||||||
|
1.0 6.0 2random >>speed
|
||||||
|
|
||||||
|
0.998 1.000 2random >>speed-d
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
[ dup theta-dd>> abs 0.00001 < ]
|
||||||
|
[ -0.001 0.001 2random >>theta-dd ]
|
||||||
|
[ ]
|
||||||
|
while
|
||||||
|
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: move { axion }
|
||||||
|
|
||||||
|
{ 0.06 0.59 } stroke
|
||||||
|
dup pos>> point
|
||||||
|
|
||||||
|
1 4 [a,b]
|
||||||
|
[| dy |
|
||||||
|
1 30 dy 6 * - 255.0 / 2array stroke
|
||||||
|
dup pos>> 0 dy neg 2array v+ point
|
||||||
|
] with-locals
|
||||||
|
each
|
||||||
|
|
||||||
|
1 4 [a,b]
|
||||||
|
[| dy |
|
||||||
|
0 30 dy 6 * - 255.0 / 2array stroke
|
||||||
|
dup pos>> dy v+y point
|
||||||
|
] with-locals
|
||||||
|
each
|
||||||
|
|
||||||
|
dup vel>> move-by
|
||||||
|
|
||||||
|
dup
|
||||||
|
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
||||||
|
>>vel
|
||||||
|
|
||||||
|
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
|
||||||
|
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
||||||
|
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
||||||
|
|
||||||
|
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
|
||||||
|
|
||||||
|
1000 random 996 >
|
||||||
|
[
|
||||||
|
dup speed>> neg >>speed
|
||||||
|
dup speed-d>> neg 2 + >>speed-d
|
||||||
|
|
||||||
|
100 random 30 >
|
||||||
|
[
|
||||||
|
dim 2 / dup 2array >>pos
|
||||||
|
collide
|
||||||
|
]
|
||||||
|
[ drop ]
|
||||||
|
if
|
||||||
|
]
|
||||||
|
[ drop ]
|
||||||
|
if ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
! : draw ( -- )
|
||||||
|
|
||||||
|
! boom>
|
||||||
|
! [ particles> [ move ] each ]
|
||||||
|
! when ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: collide-all ( -- )
|
||||||
|
|
||||||
|
2 pi * 1random >collision-theta
|
||||||
|
|
||||||
|
particles> [ collide ] each ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: collide-one ( -- )
|
||||||
|
|
||||||
|
dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
|
||||||
|
|
||||||
|
hadrons> random collide
|
||||||
|
quarks> random collide
|
||||||
|
muons> random collide ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: mouse-pressed ( -- )
|
||||||
|
boom on
|
||||||
|
1 background ! kludge
|
||||||
|
11 [ drop collide-one ] each ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: key-released ( -- )
|
||||||
|
key " " =
|
||||||
|
[
|
||||||
|
boom on
|
||||||
|
1 background
|
||||||
|
collide-all
|
||||||
|
]
|
||||||
|
when ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: bubble-chamber ( -- )
|
||||||
|
|
||||||
|
1000 1000 size*
|
||||||
|
|
||||||
|
[
|
||||||
|
1 background
|
||||||
|
no-stroke
|
||||||
|
|
||||||
|
1789 [ drop <muon> ] map >muons
|
||||||
|
1300 [ drop <quark> ] map >quarks
|
||||||
|
1000 [ drop <hadron> ] map >hadrons
|
||||||
|
111 [ drop <axion> ] map >axions
|
||||||
|
|
||||||
|
muons> quarks> hadrons> axions> 3append append >particles
|
||||||
|
|
||||||
|
collide-one
|
||||||
|
] setup
|
||||||
|
|
||||||
|
[
|
||||||
|
boom>
|
||||||
|
[ particles> [ move ] each ]
|
||||||
|
when
|
||||||
|
] draw
|
||||||
|
|
||||||
|
[ mouse-pressed ] button-down
|
||||||
|
[ key-released ] key-up
|
||||||
|
|
||||||
|
;
|
||||||
|
|
||||||
|
: go ( -- ) [ bubble-chamber run ] with-ui ;
|
||||||
|
|
||||||
|
MAIN: go
|
||||||
|
|
@ -0,0 +1,62 @@
|
||||||
|
|
||||||
|
USING: kernel arrays sequences math qualified circular processing ui ;
|
||||||
|
|
||||||
|
IN: processing.gallery.trails
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
! Example 33-15 from the Processing book
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
QUALIFIED: circular
|
||||||
|
|
||||||
|
: push-circular ( seq elt -- seq ) over circular:push-circular ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: each-percent ( seq quot -- )
|
||||||
|
>r
|
||||||
|
dup length
|
||||||
|
dup [ / ] curry
|
||||||
|
[ 1+ ] swap compose
|
||||||
|
r> compose
|
||||||
|
2each ; inline
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: dot ( pos percent -- ) 1 swap - 25 * 5 max circle ;
|
||||||
|
|
||||||
|
: step ( seq -- )
|
||||||
|
|
||||||
|
no-stroke
|
||||||
|
{ 1 0.4 } fill
|
||||||
|
|
||||||
|
0 background
|
||||||
|
|
||||||
|
mouse push-circular
|
||||||
|
[ dot ]
|
||||||
|
each-percent ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: go* ( -- )
|
||||||
|
|
||||||
|
500 500 size*
|
||||||
|
|
||||||
|
[
|
||||||
|
100 point-list
|
||||||
|
[ step ]
|
||||||
|
curry
|
||||||
|
draw
|
||||||
|
] setup
|
||||||
|
|
||||||
|
run ;
|
||||||
|
|
||||||
|
: go ( -- ) [ go* ] with-ui ;
|
||||||
|
|
||||||
|
MAIN: go
|
||||||
|
|
@ -0,0 +1,387 @@
|
||||||
|
|
||||||
|
USING: kernel namespaces threads combinators sequences arrays
|
||||||
|
math math.functions
|
||||||
|
opengl.gl opengl.glu vars multi-methods shuffle
|
||||||
|
ui
|
||||||
|
ui.gestures
|
||||||
|
ui.gadgets
|
||||||
|
combinators
|
||||||
|
combinators.lib
|
||||||
|
combinators.cleave
|
||||||
|
rewrite-closures fry accessors
|
||||||
|
processing.color
|
||||||
|
processing.gadget ;
|
||||||
|
|
||||||
|
IN: processing
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
VAR: fill-color
|
||||||
|
VAR: stroke-color
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
GENERIC: set-color ( value -- )
|
||||||
|
|
||||||
|
METHOD: set-color { number } dup dup glColor3d ;
|
||||||
|
|
||||||
|
METHOD: set-color { array }
|
||||||
|
dup length
|
||||||
|
{
|
||||||
|
{ 2 [ first2 >r dup dup r> glColor4d ] }
|
||||||
|
{ 3 [ first3 glColor3d ] }
|
||||||
|
{ 4 [ first4 glColor4d ] }
|
||||||
|
}
|
||||||
|
case ;
|
||||||
|
|
||||||
|
METHOD: set-color { rgba }
|
||||||
|
{ [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: fill ( value -- ) >fill-color ;
|
||||||
|
: stroke ( value -- ) >stroke-color ;
|
||||||
|
|
||||||
|
: no-fill ( -- )
|
||||||
|
fill-color>
|
||||||
|
{
|
||||||
|
{ [ dup number? ] [ 0 2array fill ] }
|
||||||
|
{ [ t ]
|
||||||
|
[
|
||||||
|
[ drop 0 ] [ length 1- ] [ ] tri set-nth
|
||||||
|
] }
|
||||||
|
}
|
||||||
|
cond ;
|
||||||
|
|
||||||
|
: no-stroke ( -- )
|
||||||
|
stroke-color>
|
||||||
|
{
|
||||||
|
{ [ dup number? ] [ 0 2array stroke ] }
|
||||||
|
{ [ t ]
|
||||||
|
[
|
||||||
|
[ drop 0 ] [ length 1- ] [ ] tri set-nth
|
||||||
|
] }
|
||||||
|
}
|
||||||
|
cond ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: stroke-weight ( w -- ) glLineWidth ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: point* ( x y -- )
|
||||||
|
stroke-color> set-color
|
||||||
|
GL_POINTS glBegin
|
||||||
|
glVertex2d
|
||||||
|
glEnd ;
|
||||||
|
|
||||||
|
: point ( seq -- ) first2 point* ;
|
||||||
|
|
||||||
|
: line ( x1 y1 x2 y2 -- )
|
||||||
|
stroke-color> set-color
|
||||||
|
GL_LINES glBegin
|
||||||
|
glVertex2d
|
||||||
|
glVertex2d
|
||||||
|
glEnd ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: triangle ( x1 y1 x2 y2 x3 y3 -- )
|
||||||
|
|
||||||
|
GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||||
|
fill-color> set-color
|
||||||
|
|
||||||
|
6 ndup
|
||||||
|
|
||||||
|
GL_TRIANGLES glBegin
|
||||||
|
glVertex2d
|
||||||
|
glVertex2d
|
||||||
|
glVertex2d
|
||||||
|
glEnd
|
||||||
|
|
||||||
|
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||||
|
stroke-color> set-color
|
||||||
|
|
||||||
|
GL_TRIANGLES glBegin
|
||||||
|
glVertex2d
|
||||||
|
glVertex2d
|
||||||
|
glVertex2d
|
||||||
|
glEnd ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
|
||||||
|
GL_POLYGON glBegin
|
||||||
|
glVertex2d
|
||||||
|
glVertex2d
|
||||||
|
glVertex2d
|
||||||
|
glVertex2d
|
||||||
|
glEnd ;
|
||||||
|
|
||||||
|
: quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
|
||||||
|
|
||||||
|
8 ndup
|
||||||
|
|
||||||
|
GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||||
|
fill-color> set-color
|
||||||
|
|
||||||
|
quad-vertices
|
||||||
|
|
||||||
|
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||||
|
stroke-color> set-color
|
||||||
|
|
||||||
|
quad-vertices ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: rect-vertices ( x y width height -- )
|
||||||
|
GL_POLYGON glBegin
|
||||||
|
[ 2drop glVertex2d ] 4keep
|
||||||
|
[ drop swap >r + 1- r> glVertex2d ] 4keep
|
||||||
|
[ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep
|
||||||
|
[ nip + 1- glVertex2d ] 4keep
|
||||||
|
4drop
|
||||||
|
glEnd ;
|
||||||
|
|
||||||
|
: rect ( x y width height -- )
|
||||||
|
|
||||||
|
4dup
|
||||||
|
|
||||||
|
GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||||
|
fill-color> set-color
|
||||||
|
|
||||||
|
rect-vertices
|
||||||
|
|
||||||
|
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||||
|
stroke-color> set-color
|
||||||
|
|
||||||
|
rect-vertices ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: ellipse-disk ( x y width height -- )
|
||||||
|
glPushMatrix
|
||||||
|
>r >r
|
||||||
|
0 glTranslated
|
||||||
|
r> r> 1 glScaled
|
||||||
|
gluNewQuadric
|
||||||
|
dup 0 0.5 20 1 gluDisk
|
||||||
|
gluDeleteQuadric
|
||||||
|
glPopMatrix ;
|
||||||
|
|
||||||
|
: ellipse-center ( x y width height -- )
|
||||||
|
|
||||||
|
4dup
|
||||||
|
|
||||||
|
GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||||
|
stroke-color> set-color
|
||||||
|
|
||||||
|
ellipse-disk
|
||||||
|
|
||||||
|
GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||||
|
fill-color> set-color
|
||||||
|
|
||||||
|
[ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
|
||||||
|
|
||||||
|
ellipse-disk ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
SYMBOL: CENTER
|
||||||
|
SYMBOL: RADIUS
|
||||||
|
SYMBOL: CORNER
|
||||||
|
SYMBOL: CORNERS
|
||||||
|
|
||||||
|
SYMBOL: ellipse-mode-value
|
||||||
|
|
||||||
|
: ellipse-mode ( val -- ) ellipse-mode-value set ;
|
||||||
|
|
||||||
|
: ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
|
||||||
|
|
||||||
|
: ellipse-corner ( x y width height -- )
|
||||||
|
[ drop nip 2 / + ] 4keep
|
||||||
|
[ nip rot drop 2 / + ] 4keep
|
||||||
|
[ >r >r 2drop r> r> ] 4keep
|
||||||
|
4drop
|
||||||
|
ellipse-center ;
|
||||||
|
|
||||||
|
: ellipse-corners ( x1 y1 x2 y2 -- )
|
||||||
|
[ drop nip + 2 / ] 4keep
|
||||||
|
[ nip rot drop + 2 / ] 4keep
|
||||||
|
[ drop nip - abs 1+ ] 4keep
|
||||||
|
[ nip rot drop - abs 1+ ] 4keep
|
||||||
|
4drop
|
||||||
|
ellipse-center ;
|
||||||
|
|
||||||
|
: ellipse ( a b c d -- )
|
||||||
|
ellipse-mode-value get
|
||||||
|
{
|
||||||
|
{ CENTER [ ellipse-center ] }
|
||||||
|
{ RADIUS [ ellipse-radius ] }
|
||||||
|
{ CORNER [ ellipse-corner ] }
|
||||||
|
{ CORNERS [ ellipse-corners ] }
|
||||||
|
}
|
||||||
|
case ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
USING: multi-methods ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
GENERIC: background ( value -- )
|
||||||
|
|
||||||
|
METHOD: background { number }
|
||||||
|
dup dup 1 glClearColor
|
||||||
|
GL_COLOR_BUFFER_BIT glClear ;
|
||||||
|
|
||||||
|
METHOD: background { array }
|
||||||
|
dup length
|
||||||
|
{
|
||||||
|
{ 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
|
||||||
|
{ 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
|
||||||
|
{ 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
|
||||||
|
}
|
||||||
|
case ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: translate ( x y -- ) 0 glTranslated ;
|
||||||
|
|
||||||
|
: rotate ( angle -- ) 0 0 1 glRotated ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: mouse ( -- point ) hand-loc get ;
|
||||||
|
|
||||||
|
: mouse-x mouse first ;
|
||||||
|
: mouse-y mouse second ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
VAR: frame-rate-value
|
||||||
|
|
||||||
|
: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
VAR: slate
|
||||||
|
|
||||||
|
VAR: loop-flag
|
||||||
|
|
||||||
|
: defaults ( -- )
|
||||||
|
0.8 background
|
||||||
|
0 >stroke-color
|
||||||
|
1 >fill-color
|
||||||
|
CENTER ellipse-mode
|
||||||
|
60 frame-rate ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
SYMBOL: size-val
|
||||||
|
|
||||||
|
: size ( seq -- ) size-val set ;
|
||||||
|
|
||||||
|
: size* ( width height -- ) 2array size-val set ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
SYMBOL: setup-action
|
||||||
|
SYMBOL: draw-action
|
||||||
|
|
||||||
|
! : setup ( quot -- ) closed-quot setup-action set ;
|
||||||
|
! : draw ( quot -- ) closed-quot draw-action set ;
|
||||||
|
|
||||||
|
: setup ( quot -- ) setup-action set ;
|
||||||
|
: draw ( quot -- ) draw-action set ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
SYMBOL: key-down-action
|
||||||
|
SYMBOL: key-up-action
|
||||||
|
|
||||||
|
: key-down ( quot -- ) closed-quot key-down-action set ;
|
||||||
|
: key-up ( quot -- ) closed-quot key-up-action set ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
SYMBOL: button-down-action
|
||||||
|
SYMBOL: button-up-action
|
||||||
|
|
||||||
|
: button-down ( quot -- ) closed-quot button-down-action set ;
|
||||||
|
: button-up ( quot -- ) closed-quot button-up-action set ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: start-processing-thread ( -- )
|
||||||
|
loop-flag get not
|
||||||
|
[
|
||||||
|
loop-flag on
|
||||||
|
[
|
||||||
|
[ loop-flag get ]
|
||||||
|
processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
|
||||||
|
[ ]
|
||||||
|
while
|
||||||
|
]
|
||||||
|
in-thread
|
||||||
|
]
|
||||||
|
when ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: get-size ( -- size ) processing-gadget get rect-dim ;
|
||||||
|
|
||||||
|
: width ( -- width ) get-size first ;
|
||||||
|
: height ( -- height ) get-size second ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
SYMBOL: setup-called
|
||||||
|
|
||||||
|
: setup-called? ( -- ? ) setup-called get ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: run ( -- )
|
||||||
|
|
||||||
|
loop-flag off
|
||||||
|
|
||||||
|
500 sleep
|
||||||
|
|
||||||
|
<processing-gadget>
|
||||||
|
size-val get >>dim
|
||||||
|
dup "Processing" open-window
|
||||||
|
|
||||||
|
500 sleep
|
||||||
|
|
||||||
|
defaults
|
||||||
|
|
||||||
|
setup-called off
|
||||||
|
|
||||||
|
[
|
||||||
|
setup-called? not
|
||||||
|
[
|
||||||
|
setup-action get call
|
||||||
|
setup-called on
|
||||||
|
]
|
||||||
|
[
|
||||||
|
draw-action get call
|
||||||
|
]
|
||||||
|
if
|
||||||
|
]
|
||||||
|
closed-quot >>action
|
||||||
|
|
||||||
|
key-down-action get >>key-down
|
||||||
|
key-up-action get >>key-up
|
||||||
|
|
||||||
|
button-down-action get >>button-down
|
||||||
|
button-up-action get >>button-up
|
||||||
|
|
||||||
|
processing-gadget set
|
||||||
|
|
||||||
|
start-processing-thread ;
|
||||||
|
|
@ -26,8 +26,7 @@ M: pair make-disassemble-cmd
|
||||||
M: method-spec make-disassemble-cmd
|
M: method-spec make-disassemble-cmd
|
||||||
first2 method make-disassemble-cmd ;
|
first2 method make-disassemble-cmd ;
|
||||||
|
|
||||||
: gdb-binary ( -- string )
|
: gdb-binary ( -- string ) "gdb" ;
|
||||||
os freebsd? "gdb66" "gdb" ? ;
|
|
||||||
|
|
||||||
: run-gdb ( -- lines )
|
: run-gdb ( -- lines )
|
||||||
<process>
|
<process>
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,113 @@
|
||||||
|
|
||||||
|
USING: kernel alien.c-types combinators sequences splitting
|
||||||
|
opengl.gl ui.gadgets ui.render
|
||||||
|
math math.vectors accessors ;
|
||||||
|
|
||||||
|
IN: ui.gadgets.frame-buffer
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
|
||||||
|
dup
|
||||||
|
rect-dim product "uint[4]" <c-array>
|
||||||
|
>>pixels ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: <frame-buffer> ( -- frame-buffer )
|
||||||
|
frame-buffer construct-gadget
|
||||||
|
[ ] >>action
|
||||||
|
{ 100 100 } >>dim
|
||||||
|
[ ] >>graft
|
||||||
|
[ ] >>ungraft ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: draw-pixels ( fb -- fb )
|
||||||
|
dup >r
|
||||||
|
dup >r
|
||||||
|
rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
|
||||||
|
r> ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: read-pixels ( fb -- fb )
|
||||||
|
dup >r
|
||||||
|
dup >r
|
||||||
|
>r
|
||||||
|
0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
|
||||||
|
r> ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
M: frame-buffer pref-dim* dim>> ;
|
||||||
|
M: frame-buffer graft* graft>> call ;
|
||||||
|
M: frame-buffer ungraft* ungraft>> call ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: copy-row ( old new -- )
|
||||||
|
2dup min-length swap >r head-slice 0 r> copy ;
|
||||||
|
|
||||||
|
! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
|
||||||
|
! [ group ] 2bi@
|
||||||
|
! [ copy-row ] 2each ;
|
||||||
|
|
||||||
|
! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
|
||||||
|
! [ 16 * group ] 2bi@
|
||||||
|
! [ copy-row ] 2each ;
|
||||||
|
|
||||||
|
: copy-pixels ( old-pixels old-width new-pixels new-width -- )
|
||||||
|
[ 16 * <sliced-groups> ] 2bi@
|
||||||
|
[ copy-row ] 2each ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
M: frame-buffer layout* ( fb -- )
|
||||||
|
{
|
||||||
|
{
|
||||||
|
[ dup last-dim>> f = ]
|
||||||
|
[
|
||||||
|
init-frame-buffer-pixels
|
||||||
|
dup
|
||||||
|
rect-dim >>last-dim
|
||||||
|
drop
|
||||||
|
]
|
||||||
|
}
|
||||||
|
{
|
||||||
|
[ dup [ rect-dim ] [ last-dim>> ] bi = not ]
|
||||||
|
[
|
||||||
|
dup [ pixels>> ] [ last-dim>> first ] bi
|
||||||
|
|
||||||
|
rot init-frame-buffer-pixels
|
||||||
|
dup rect-dim >>last-dim
|
||||||
|
|
||||||
|
[ pixels>> ] [ rect-dim first ] bi
|
||||||
|
|
||||||
|
copy-pixels
|
||||||
|
]
|
||||||
|
}
|
||||||
|
{ [ t ] [ drop ] }
|
||||||
|
}
|
||||||
|
cond ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
M: frame-buffer draw-gadget* ( fb -- )
|
||||||
|
|
||||||
|
dup rect-dim { 0 1 } v* first2 glRasterPos2i
|
||||||
|
|
||||||
|
draw-pixels
|
||||||
|
|
||||||
|
dup action>> call
|
||||||
|
|
||||||
|
glFlush
|
||||||
|
|
||||||
|
read-pixels
|
||||||
|
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
|
@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled
|
||||||
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
|
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
|
||||||
ui.gadgets.tracks ui.gestures ui.operations vocabs words
|
ui.gadgets.tracks ui.gestures ui.operations vocabs words
|
||||||
prettyprint listener debugger threads boxes concurrency.flags
|
prettyprint listener debugger threads boxes concurrency.flags
|
||||||
math arrays generic accessors ;
|
math arrays generic accessors combinators ;
|
||||||
IN: ui.tools.listener
|
IN: ui.tools.listener
|
||||||
|
|
||||||
TUPLE: listener-gadget input output stack ;
|
TUPLE: listener-gadget input output stack ;
|
||||||
|
|
@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- )
|
||||||
: clear-stack ( listener -- )
|
: clear-stack ( listener -- )
|
||||||
[ clear ] swap (call-listener) ;
|
[ clear ] swap (call-listener) ;
|
||||||
|
|
||||||
GENERIC# word-completion-string 1 ( word listener -- string )
|
GENERIC: word-completion-string ( word -- string )
|
||||||
|
|
||||||
|
M: word word-completion-string
|
||||||
|
word-name ;
|
||||||
|
|
||||||
M: method-body word-completion-string
|
M: method-body word-completion-string
|
||||||
>r "method-generic" word-prop r> word-completion-string ;
|
"method-generic" word-prop word-completion-string ;
|
||||||
|
|
||||||
USE: generic.standard.engines.tuple
|
USE: generic.standard.engines.tuple
|
||||||
|
|
||||||
M: tuple-dispatch-engine-word word-completion-string
|
M: tuple-dispatch-engine-word word-completion-string
|
||||||
>r "engine-generic" word-prop r> word-completion-string ;
|
"engine-generic" word-prop word-completion-string ;
|
||||||
|
|
||||||
M: word word-completion-string ( word listener -- string )
|
: use-if-necessary ( word seq -- )
|
||||||
>r [ word-name ] [ word-vocabulary ] bi dup vocab-words r>
|
>r word-vocabulary vocab-words r>
|
||||||
input>> interactor-use memq?
|
{
|
||||||
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
|
{ [ dup not ] [ 2drop ] }
|
||||||
|
{ [ 2dup memq? ] [ 2drop ] }
|
||||||
|
{ [ t ] [ push ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: insert-word ( word -- )
|
: insert-word ( word -- )
|
||||||
get-workspace
|
get-workspace workspace-listener input>>
|
||||||
workspace-listener
|
[ >r word-completion-string r> user-input ]
|
||||||
[ word-completion-string ] keep
|
[ interactor-use use-if-necessary ]
|
||||||
input>> user-input ;
|
2bi ;
|
||||||
|
|
||||||
: quot-action ( interactor -- lines )
|
: quot-action ( interactor -- lines )
|
||||||
dup control-value
|
dup control-value
|
||||||
|
|
|
||||||
|
|
@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear)
|
||||||
{
|
{
|
||||||
throw_impl(dpop(),stack_chain->callstack_bottom);
|
throw_impl(dpop(),stack_chain->callstack_bottom);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* For testing purposes */
|
||||||
|
DEFINE_PRIMITIVE(unimplemented)
|
||||||
|
{
|
||||||
|
not_implemented_error();
|
||||||
|
}
|
||||||
|
|
|
||||||
|
|
@ -55,3 +55,5 @@ void *signal_callstack_top;
|
||||||
void memory_signal_handler_impl(void);
|
void memory_signal_handler_impl(void);
|
||||||
void divide_by_zero_signal_handler_impl(void);
|
void divide_by_zero_signal_handler_impl(void);
|
||||||
void misc_signal_handler_impl(void);
|
void misc_signal_handler_impl(void);
|
||||||
|
|
||||||
|
DECLARE_PRIMITIVE(unimplemented);
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,687 @@
|
||||||
|
.file "errors.c"
|
||||||
|
.section .rdata,"dr"
|
||||||
|
LC0:
|
||||||
|
.ascii "fatal_error: %s %lx\12\0"
|
||||||
|
.text
|
||||||
|
.globl _fatal_error
|
||||||
|
.def _fatal_error; .scl 2; .type 32; .endef
|
||||||
|
_fatal_error:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $24, %esp
|
||||||
|
call ___getreent
|
||||||
|
movl %eax, %edx
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, 8(%esp)
|
||||||
|
movl $LC0, 4(%esp)
|
||||||
|
movl 12(%edx), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _fprintf
|
||||||
|
movl $1, (%esp)
|
||||||
|
call _exit
|
||||||
|
.section .rdata,"dr"
|
||||||
|
.align 4
|
||||||
|
LC1:
|
||||||
|
.ascii "You have triggered a bug in Factor. Please report.\12\0"
|
||||||
|
LC2:
|
||||||
|
.ascii "critical_error: %s %lx\12\0"
|
||||||
|
.text
|
||||||
|
.globl _critical_error
|
||||||
|
.def _critical_error; .scl 2; .type 32; .endef
|
||||||
|
_critical_error:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $24, %esp
|
||||||
|
call ___getreent
|
||||||
|
movl $LC1, 4(%esp)
|
||||||
|
movl 12(%eax), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _fprintf
|
||||||
|
call ___getreent
|
||||||
|
movl %eax, %edx
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, 8(%esp)
|
||||||
|
movl $LC2, 4(%esp)
|
||||||
|
movl 12(%edx), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _fprintf
|
||||||
|
call _factorbug
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.section .rdata,"dr"
|
||||||
|
LC3:
|
||||||
|
.ascii "early_error: \0"
|
||||||
|
LC4:
|
||||||
|
.ascii "\12\0"
|
||||||
|
.text
|
||||||
|
.globl _throw_error
|
||||||
|
.def _throw_error; .scl 2; .type 32; .endef
|
||||||
|
_throw_error:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
cmpl $7, _userenv+20
|
||||||
|
je L4
|
||||||
|
movb $0, _gc_off
|
||||||
|
movl _gc_locals_region, %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
subl $4, %eax
|
||||||
|
movl %eax, _gc_locals
|
||||||
|
movl _extra_roots_region, %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
subl $4, %eax
|
||||||
|
movl %eax, _extra_roots
|
||||||
|
call _fix_stacks
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _dpush
|
||||||
|
cmpl $0, 12(%ebp)
|
||||||
|
je L5
|
||||||
|
movl _stack_chain, %eax
|
||||||
|
movl 4(%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _fix_callstack_top
|
||||||
|
movl %eax, 12(%ebp)
|
||||||
|
jmp L6
|
||||||
|
L5:
|
||||||
|
movl _stack_chain, %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
movl %eax, 12(%ebp)
|
||||||
|
L6:
|
||||||
|
movl 12(%ebp), %edx
|
||||||
|
movl _userenv+20, %eax
|
||||||
|
call _throw_impl
|
||||||
|
jmp L3
|
||||||
|
L4:
|
||||||
|
call ___getreent
|
||||||
|
movl $LC1, 4(%esp)
|
||||||
|
movl 12(%eax), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _fprintf
|
||||||
|
call ___getreent
|
||||||
|
movl $LC3, 4(%esp)
|
||||||
|
movl 12(%eax), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _fprintf
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _print_obj
|
||||||
|
call ___getreent
|
||||||
|
movl $LC4, 4(%esp)
|
||||||
|
movl 12(%eax), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _fprintf
|
||||||
|
call _factorbug
|
||||||
|
L3:
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _dpush; .scl 3; .type 32; .endef
|
||||||
|
_dpush:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
addl $4, %esi
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl %esi, (%esp)
|
||||||
|
call _put
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _put; .scl 3; .type 32; .endef
|
||||||
|
_put:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
movl 8(%ebp), %edx
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, (%edx)
|
||||||
|
popl %ebp
|
||||||
|
ret
|
||||||
|
.globl _general_error
|
||||||
|
.def _general_error; .scl 2; .type 32; .endef
|
||||||
|
_general_error:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $24, %esp
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _tag_fixnum
|
||||||
|
movl %eax, %edx
|
||||||
|
movl 16(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 8(%esp)
|
||||||
|
movl %edx, 4(%esp)
|
||||||
|
movl _userenv+24, %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _allot_array_4
|
||||||
|
movl %eax, %edx
|
||||||
|
movl 20(%ebp), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl %edx, (%esp)
|
||||||
|
call _throw_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _tag_fixnum; .scl 3; .type 32; .endef
|
||||||
|
_tag_fixnum:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
sall $3, %eax
|
||||||
|
andl $-8, %eax
|
||||||
|
popl %ebp
|
||||||
|
ret
|
||||||
|
.globl _type_error
|
||||||
|
.def _type_error; .scl 2; .type 32; .endef
|
||||||
|
_type_error:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $24, %esp
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _tag_fixnum
|
||||||
|
movl %eax, %edx
|
||||||
|
movl $0, 12(%esp)
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 8(%esp)
|
||||||
|
movl %edx, 4(%esp)
|
||||||
|
movl $3, (%esp)
|
||||||
|
call _general_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.globl _not_implemented_error
|
||||||
|
.def _not_implemented_error; .scl 2; .type 32; .endef
|
||||||
|
_not_implemented_error:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $24, %esp
|
||||||
|
movl $0, 12(%esp)
|
||||||
|
movl $7, 8(%esp)
|
||||||
|
movl $7, 4(%esp)
|
||||||
|
movl $2, (%esp)
|
||||||
|
call _general_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.globl _in_page
|
||||||
|
.def _in_page; .scl 2; .type 32; .endef
|
||||||
|
_in_page:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
call _getpagesize
|
||||||
|
movl %eax, -4(%ebp)
|
||||||
|
movl 16(%ebp), %edx
|
||||||
|
leal 12(%ebp), %eax
|
||||||
|
addl %edx, (%eax)
|
||||||
|
movl 20(%ebp), %eax
|
||||||
|
movl %eax, %edx
|
||||||
|
imull -4(%ebp), %edx
|
||||||
|
leal 12(%ebp), %eax
|
||||||
|
addl %edx, (%eax)
|
||||||
|
movb $0, -5(%ebp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
cmpl 12(%ebp), %eax
|
||||||
|
jb L15
|
||||||
|
movl -4(%ebp), %eax
|
||||||
|
addl 12(%ebp), %eax
|
||||||
|
cmpl 8(%ebp), %eax
|
||||||
|
jb L15
|
||||||
|
movb $1, -5(%ebp)
|
||||||
|
L15:
|
||||||
|
movzbl -5(%ebp), %eax
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.section .rdata,"dr"
|
||||||
|
.align 4
|
||||||
|
LC5:
|
||||||
|
.ascii "allot_object() missed GC check\0"
|
||||||
|
LC6:
|
||||||
|
.ascii "gc locals underflow\0"
|
||||||
|
LC7:
|
||||||
|
.ascii "gc locals overflow\0"
|
||||||
|
LC8:
|
||||||
|
.ascii "extra roots underflow\0"
|
||||||
|
LC9:
|
||||||
|
.ascii "extra roots overflow\0"
|
||||||
|
.text
|
||||||
|
.globl _memory_protection_error
|
||||||
|
.def _memory_protection_error; .scl 2; .type 32; .endef
|
||||||
|
_memory_protection_error:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $24, %esp
|
||||||
|
movl $-1, 12(%esp)
|
||||||
|
movl $0, 8(%esp)
|
||||||
|
movl _stack_chain, %eax
|
||||||
|
movl 24(%eax), %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _in_page
|
||||||
|
testb %al, %al
|
||||||
|
je L17
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl $7, 8(%esp)
|
||||||
|
movl $7, 4(%esp)
|
||||||
|
movl $11, (%esp)
|
||||||
|
call _general_error
|
||||||
|
jmp L16
|
||||||
|
L17:
|
||||||
|
movl $0, 12(%esp)
|
||||||
|
movl _ds_size, %eax
|
||||||
|
movl %eax, 8(%esp)
|
||||||
|
movl _stack_chain, %eax
|
||||||
|
movl 24(%eax), %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _in_page
|
||||||
|
testb %al, %al
|
||||||
|
je L19
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl $7, 8(%esp)
|
||||||
|
movl $7, 4(%esp)
|
||||||
|
movl $12, (%esp)
|
||||||
|
call _general_error
|
||||||
|
jmp L16
|
||||||
|
L19:
|
||||||
|
movl $-1, 12(%esp)
|
||||||
|
movl $0, 8(%esp)
|
||||||
|
movl _stack_chain, %eax
|
||||||
|
movl 28(%eax), %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _in_page
|
||||||
|
testb %al, %al
|
||||||
|
je L21
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl $7, 8(%esp)
|
||||||
|
movl $7, 4(%esp)
|
||||||
|
movl $13, (%esp)
|
||||||
|
call _general_error
|
||||||
|
jmp L16
|
||||||
|
L21:
|
||||||
|
movl $0, 12(%esp)
|
||||||
|
movl _rs_size, %eax
|
||||||
|
movl %eax, 8(%esp)
|
||||||
|
movl _stack_chain, %eax
|
||||||
|
movl 28(%eax), %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _in_page
|
||||||
|
testb %al, %al
|
||||||
|
je L23
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl $7, 8(%esp)
|
||||||
|
movl $7, 4(%esp)
|
||||||
|
movl $14, (%esp)
|
||||||
|
call _general_error
|
||||||
|
jmp L16
|
||||||
|
L23:
|
||||||
|
movl $0, 12(%esp)
|
||||||
|
movl $0, 8(%esp)
|
||||||
|
movl _nursery, %eax
|
||||||
|
movl 12(%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _in_page
|
||||||
|
testb %al, %al
|
||||||
|
je L25
|
||||||
|
movl $0, 4(%esp)
|
||||||
|
movl $LC5, (%esp)
|
||||||
|
call _critical_error
|
||||||
|
jmp L16
|
||||||
|
L25:
|
||||||
|
movl $-1, 12(%esp)
|
||||||
|
movl $0, 8(%esp)
|
||||||
|
movl _gc_locals_region, %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _in_page
|
||||||
|
testb %al, %al
|
||||||
|
je L27
|
||||||
|
movl $0, 4(%esp)
|
||||||
|
movl $LC6, (%esp)
|
||||||
|
call _critical_error
|
||||||
|
jmp L16
|
||||||
|
L27:
|
||||||
|
movl $0, 12(%esp)
|
||||||
|
movl $0, 8(%esp)
|
||||||
|
movl _gc_locals_region, %eax
|
||||||
|
movl 8(%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _in_page
|
||||||
|
testb %al, %al
|
||||||
|
je L29
|
||||||
|
movl $0, 4(%esp)
|
||||||
|
movl $LC7, (%esp)
|
||||||
|
call _critical_error
|
||||||
|
jmp L16
|
||||||
|
L29:
|
||||||
|
movl $-1, 12(%esp)
|
||||||
|
movl $0, 8(%esp)
|
||||||
|
movl _extra_roots_region, %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _in_page
|
||||||
|
testb %al, %al
|
||||||
|
je L31
|
||||||
|
movl $0, 4(%esp)
|
||||||
|
movl $LC8, (%esp)
|
||||||
|
call _critical_error
|
||||||
|
jmp L16
|
||||||
|
L31:
|
||||||
|
movl $0, 12(%esp)
|
||||||
|
movl $0, 8(%esp)
|
||||||
|
movl _extra_roots_region, %eax
|
||||||
|
movl 8(%eax), %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _in_page
|
||||||
|
testb %al, %al
|
||||||
|
je L33
|
||||||
|
movl $0, 4(%esp)
|
||||||
|
movl $LC9, (%esp)
|
||||||
|
call _critical_error
|
||||||
|
jmp L16
|
||||||
|
L33:
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _allot_cell
|
||||||
|
movl %eax, %edx
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl $7, 8(%esp)
|
||||||
|
movl %edx, 4(%esp)
|
||||||
|
movl $15, (%esp)
|
||||||
|
call _general_error
|
||||||
|
L16:
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _allot_cell; .scl 3; .type 32; .endef
|
||||||
|
_allot_cell:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
cmpl $268435455, 8(%ebp)
|
||||||
|
jbe L36
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _cell_to_bignum
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _tag_bignum
|
||||||
|
movl %eax, -4(%ebp)
|
||||||
|
jmp L35
|
||||||
|
L36:
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _tag_fixnum
|
||||||
|
movl %eax, -4(%ebp)
|
||||||
|
L35:
|
||||||
|
movl -4(%ebp), %eax
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _tag_bignum; .scl 3; .type 32; .endef
|
||||||
|
_tag_bignum:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
andl $-8, %eax
|
||||||
|
orl $1, %eax
|
||||||
|
popl %ebp
|
||||||
|
ret
|
||||||
|
.globl _signal_error
|
||||||
|
.def _signal_error; .scl 2; .type 32; .endef
|
||||||
|
_signal_error:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $24, %esp
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _tag_fixnum
|
||||||
|
movl %eax, %edx
|
||||||
|
movl 12(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl $7, 8(%esp)
|
||||||
|
movl %edx, 4(%esp)
|
||||||
|
movl $5, (%esp)
|
||||||
|
call _general_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.globl _divide_by_zero_error
|
||||||
|
.def _divide_by_zero_error; .scl 2; .type 32; .endef
|
||||||
|
_divide_by_zero_error:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $24, %esp
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl %eax, 12(%esp)
|
||||||
|
movl $7, 8(%esp)
|
||||||
|
movl $7, 4(%esp)
|
||||||
|
movl $4, (%esp)
|
||||||
|
call _general_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.globl _memory_signal_handler_impl
|
||||||
|
.def _memory_signal_handler_impl; .scl 2; .type 32; .endef
|
||||||
|
_memory_signal_handler_impl:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
movl _signal_callstack_top, %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl _signal_fault_addr, %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _memory_protection_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.globl _divide_by_zero_signal_handler_impl
|
||||||
|
.def _divide_by_zero_signal_handler_impl; .scl 2; .type 32; .endef
|
||||||
|
_divide_by_zero_signal_handler_impl:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
movl _signal_callstack_top, %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _divide_by_zero_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.globl _misc_signal_handler_impl
|
||||||
|
.def _misc_signal_handler_impl; .scl 2; .type 32; .endef
|
||||||
|
_misc_signal_handler_impl:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
movl _signal_callstack_top, %eax
|
||||||
|
movl %eax, 4(%esp)
|
||||||
|
movl _signal_number, %eax
|
||||||
|
movl %eax, (%esp)
|
||||||
|
call _signal_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.globl _primitive_throw
|
||||||
|
.def _primitive_throw; .scl 2; .type 32; .endef
|
||||||
|
_primitive_throw:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
movl %eax, -4(%ebp)
|
||||||
|
movl %edx, -8(%ebp)
|
||||||
|
movl -8(%ebp), %eax
|
||||||
|
call _save_callstack_top
|
||||||
|
call _primitive_throw_impl
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _primitive_throw_impl; .scl 3; .type 32; .endef
|
||||||
|
_primitive_throw_impl:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
call _dpop
|
||||||
|
call _dpop
|
||||||
|
movl %eax, %ecx
|
||||||
|
movl _stack_chain, %eax
|
||||||
|
movl (%eax), %edx
|
||||||
|
movl %ecx, %eax
|
||||||
|
call _throw_impl
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _dpop; .scl 3; .type 32; .endef
|
||||||
|
_dpop:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
movl %esi, (%esp)
|
||||||
|
call _get
|
||||||
|
movl %eax, -4(%ebp)
|
||||||
|
subl $4, %esi
|
||||||
|
movl -4(%ebp), %eax
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _get; .scl 3; .type 32; .endef
|
||||||
|
_get:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
movl 8(%ebp), %eax
|
||||||
|
movl (%eax), %eax
|
||||||
|
popl %ebp
|
||||||
|
ret
|
||||||
|
.globl _primitive_call_clear
|
||||||
|
.def _primitive_call_clear; .scl 2; .type 32; .endef
|
||||||
|
_primitive_call_clear:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
movl %eax, -4(%ebp)
|
||||||
|
movl %edx, -8(%ebp)
|
||||||
|
movl -8(%ebp), %eax
|
||||||
|
call _save_callstack_top
|
||||||
|
call _primitive_call_clear_impl
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _primitive_call_clear_impl; .scl 3; .type 32; .endef
|
||||||
|
_primitive_call_clear_impl:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
call _dpop
|
||||||
|
movl _stack_chain, %edx
|
||||||
|
movl 4(%edx), %edx
|
||||||
|
call _throw_impl
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.globl _primitive_unimplemented2
|
||||||
|
.def _primitive_unimplemented2; .scl 2; .type 32; .endef
|
||||||
|
_primitive_unimplemented2:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
movl %eax, -4(%ebp)
|
||||||
|
movl %edx, -8(%ebp)
|
||||||
|
call _not_implemented_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.globl _primitive_unimplemented
|
||||||
|
.def _primitive_unimplemented; .scl 2; .type 32; .endef
|
||||||
|
_primitive_unimplemented:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
movl %eax, -4(%ebp)
|
||||||
|
movl %edx, -8(%ebp)
|
||||||
|
movl -8(%ebp), %eax
|
||||||
|
call _save_callstack_top
|
||||||
|
call _primitive_unimplemented_impl
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.def _primitive_unimplemented_impl; .scl 3; .type 32; .endef
|
||||||
|
_primitive_unimplemented_impl:
|
||||||
|
pushl %ebp
|
||||||
|
movl %esp, %ebp
|
||||||
|
subl $8, %esp
|
||||||
|
call _not_implemented_error
|
||||||
|
leave
|
||||||
|
ret
|
||||||
|
.comm _console_open, 16 # 1
|
||||||
|
.comm _userenv, 256 # 256
|
||||||
|
.comm _T, 16 # 4
|
||||||
|
.comm _stack_chain, 16 # 4
|
||||||
|
.comm _ds_size, 16 # 4
|
||||||
|
.comm _rs_size, 16 # 4
|
||||||
|
.comm _stage2, 16 # 1
|
||||||
|
.comm _profiling_p, 16 # 1
|
||||||
|
.comm _signal_number, 16 # 4
|
||||||
|
.comm _signal_fault_addr, 16 # 4
|
||||||
|
.comm _signal_callstack_top, 16 # 4
|
||||||
|
.comm _secure_gc, 16 # 1
|
||||||
|
.comm _data_heap, 16 # 4
|
||||||
|
.comm _cards_offset, 16 # 4
|
||||||
|
.comm _newspace, 16 # 4
|
||||||
|
.comm _nursery, 16 # 4
|
||||||
|
.comm _gc_time, 16 # 8
|
||||||
|
.comm _nursery_collections, 16 # 4
|
||||||
|
.comm _aging_collections, 16 # 4
|
||||||
|
.comm _cards_scanned, 16 # 4
|
||||||
|
.comm _performing_gc, 16 # 1
|
||||||
|
.comm _collecting_gen, 16 # 4
|
||||||
|
.comm _collecting_aging_again, 16 # 1
|
||||||
|
.comm _last_code_heap_scan, 16 # 4
|
||||||
|
.comm _growing_data_heap, 16 # 1
|
||||||
|
.comm _old_data_heap, 16 # 4
|
||||||
|
.comm _gc_jmp, 208 # 208
|
||||||
|
.comm _heap_scan_ptr, 16 # 4
|
||||||
|
.comm _gc_off, 16 # 1
|
||||||
|
.comm _gc_locals_region, 16 # 4
|
||||||
|
.comm _gc_locals, 16 # 4
|
||||||
|
.comm _extra_roots_region, 16 # 4
|
||||||
|
.comm _extra_roots, 16 # 4
|
||||||
|
.comm _bignum_zero, 16 # 4
|
||||||
|
.comm _bignum_pos_one, 16 # 4
|
||||||
|
.comm _bignum_neg_one, 16 # 4
|
||||||
|
.comm _code_heap, 16 # 8
|
||||||
|
.comm _data_relocation_base, 16 # 4
|
||||||
|
.comm _code_relocation_base, 16 # 4
|
||||||
|
.comm _posix_argc, 16 # 4
|
||||||
|
.comm _posix_argv, 16 # 4
|
||||||
|
.def _save_callstack_top; .scl 3; .type 32; .endef
|
||||||
|
.def _getpagesize; .scl 3; .type 32; .endef
|
||||||
|
.def _allot_array_4; .scl 3; .type 32; .endef
|
||||||
|
.def _print_obj; .scl 3; .type 32; .endef
|
||||||
|
.def _throw_impl; .scl 3; .type 32; .endef
|
||||||
|
.def _fix_callstack_top; .scl 3; .type 32; .endef
|
||||||
|
.def _fix_stacks; .scl 3; .type 32; .endef
|
||||||
|
.def _factorbug; .scl 3; .type 32; .endef
|
||||||
|
.def _exit; .scl 3; .type 32; .endef
|
||||||
|
.def ___getreent; .scl 3; .type 32; .endef
|
||||||
|
.def _fprintf; .scl 3; .type 32; .endef
|
||||||
|
.def _critical_error; .scl 3; .type 32; .endef
|
||||||
|
.def _type_error; .scl 3; .type 32; .endef
|
||||||
|
.section .drectve
|
||||||
|
|
||||||
|
.ascii " -export:nursery,data"
|
||||||
|
.ascii " -export:cards_offset,data"
|
||||||
|
.ascii " -export:stack_chain,data"
|
||||||
|
.ascii " -export:userenv,data"
|
||||||
|
|
@ -215,7 +215,7 @@ void sleep_millis(DWORD msec)
|
||||||
Sleep(msec);
|
Sleep(msec);
|
||||||
}
|
}
|
||||||
|
|
||||||
DECLARE_PRIMITIVE(set_os_envs)
|
DEFINE_PRIMITIVE(set_os_envs)
|
||||||
{
|
{
|
||||||
not_implemented_error();
|
not_implemented_error();
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -187,4 +187,5 @@ void *primitives[] = {
|
||||||
primitive_resize_bit_array,
|
primitive_resize_bit_array,
|
||||||
primitive_resize_float_array,
|
primitive_resize_float_array,
|
||||||
primitive_dll_validp,
|
primitive_dll_validp,
|
||||||
|
primitive_unimplemented,
|
||||||
};
|
};
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue