diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5836b4d3c5..233de6f4ee 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -737,6 +737,7 @@ define-builtin { "resize-bit-array" "bit-arrays" } { "resize-float-array" "float-arrays" } { "dll-valid?" "alien" } + { "unimplemented" "kernel.private" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 99737e0ac5..8f505c21a1 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -594,3 +594,5 @@ set-primitive-effect \ dll-valid? { object } { object } set-primitive-effect \ modify-code-heap { array object } { } set-primitive-effect + +\ unimplemented { } { } set-primitive-effect diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 1dd96a13fc..e3f86c079d 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -7,14 +7,15 @@ ARTICLE: "file-streams" "Reading and writing files" { $subsection } { $subsection } { $subsection } +"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:" { $subsection with-file-reader } { $subsection with-file-writer } -{ $subsection with-file-appender } -{ $subsection set-file-contents } -{ $subsection file-contents } -{ $subsection set-file-lines } -{ $subsection file-lines } ; +{ $subsection with-file-appender } ; ARTICLE: "pathnames" "Pathname manipulation" "Pathname manipulation:" diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 3c40984d7a..4b129ad59d 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -108,3 +108,12 @@ IN: kernel.tests H{ } values swap >r dup length swap r> 0 -roll (loop) ; [ 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 diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 5adecca206..d11f036445 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -284,10 +284,6 @@ HELP: use HELP: in { $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+) { $values { "vocab" "an assoc mapping strings to words" } } { $description "Adds an assoc at the front of the search path." } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7db7e46b3a..6d091fd1c0 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -191,22 +191,8 @@ SYMBOL: in : word/vocab% ( word -- ) "(" % 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 -- ) - vocab-words use get 2dup shadow-warnings push ; + vocab-words use get push ; : use+ ( vocab -- ) load-vocab (use+) ; diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor index fac6471b8c..8b13b9b3b9 100755 --- a/extra/io/windows/nt/launcher/launcher-tests.factor +++ b/extra/io/windows/nt/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ IN: io.windows.launcher.nt.tests USING: io.launcher tools.test calendar accessors namespaces kernel system arrays io io.files io.encodings.ascii -sequences parser assocs hashtables ; +sequences parser assocs hashtables math ; [ ] [ @@ -129,3 +129,14 @@ sequences parser assocs hashtables ; "HOME" swap at "XXX" = ] unit-test + +2 [ + [ ] [ + + "cmd.exe /c dir" >>command + "dir.txt" temp-file >>stdout + try-process + ] unit-test + + [ ] [ "dir.txt" temp-file delete-file ] unit-test +] times diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index a01ba4698e..97de248d24 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -39,7 +39,7 @@ IN: io.windows.nt.launcher create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file - CreateFile dup invalid-handle? dup close-later ; + CreateFile dup invalid-handle? dup close-always ; : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 5ea19bc957..115432b14d 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -70,6 +70,9 @@ PREDICATE: method-body < word M: method-body stack-effect "multi-method" word-prop method-generic stack-effect ; +M: method-body crossref? + drop t ; + : method-word-name ( classes generic -- string ) [ word-name % diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index ae92f8f6c0..df826dc295 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -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 ! their primary object. However, the 'mutate' qualifier is supposed to ! indicate that this is the main objective of the word, as a side effect. \ No newline at end of file diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor index d49f1158dd..d71fdaea3b 100755 --- a/extra/peg/parsers/parsers-docs.factor +++ b/extra/peg/parsers/parsers-docs.factor @@ -173,7 +173,7 @@ HELP: range-pattern "of characters separated with a dash (-) represents the " "range of characters from the first to the second, inclusive." { $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 ;" "\"0\" \"^0-9\" range-pattern parse ." "f" } + { $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 ;\n\"0\" \"^0-9\" range-pattern parse ." "f" } } } ; diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 49035ea43c..3bbb61b846 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. 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 peg.search math.ranges words memoize ; IN: peg.parsers diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 5f200be78e..10e05a2512 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -104,8 +104,8 @@ HELP: semantic "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." } { $examples - { $example "\"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 ;" "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse ." "f" } + { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast ." "67" } } ; HELP: ensure diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8d5d1c1560..ee9037ff25 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. 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 words quotations effects memoize accessors locals effects splitting ; IN: peg @@ -241,7 +241,7 @@ GENERIC: (compile) ( parser -- quot ) : compiled-parse ( state word -- result ) swap [ execute ] with-packrat ; inline -: parse ( state parser -- result ) +: parse ( input parser -- result ) dup word? [ compile ] unless compiled-parse ; r ?head-slice [ @@ -388,9 +386,6 @@ M: optional-parser (compile) ( parser -- quot ) p1>> compiled-parser 1quotation '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; -MATCH-VARS: ?quot ; - -MATCH-VARS: ?parser ; : check-semantic ( result quot -- result ) over [ @@ -421,8 +416,6 @@ M: ensure-not-parser (compile) ( parser -- quot ) TUPLE: action-parser p1 quot ; -MATCH-VARS: ?action ; - : check-action ( result quot -- result ) over [ over ast>> swap call >>ast diff --git a/extra/processing/color/color.factor b/extra/processing/color/color.factor new file mode 100644 index 0000000000..50d20fcf52 --- /dev/null +++ b/extra/processing/color/color.factor @@ -0,0 +1,22 @@ + +USING: kernel sequences ; + +IN: processing.color + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: rgba red green blue alpha ; + +C: rgba + +: ( r g b -- rgba ) 1 ; + +: ( gray -- rgba ) dup dup 1 ; + +: {rgb} ( seq -- rgba ) first3 ; + +! : hex>rgba ( hex -- rgba ) + +! : set-gl-color ( color -- ) +! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ; + diff --git a/extra/processing/gadget/gadget.factor b/extra/processing/gadget/gadget.factor new file mode 100644 index 0000000000..8b78c43f00 --- /dev/null +++ b/extra/processing/gadget/gadget.factor @@ -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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: ( -- gadget ) + processing-gadget construct-empty + 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 ; \ No newline at end of file diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor new file mode 100644 index 0000000000..c6e000e74f --- /dev/null +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -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 / 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 construct-empty + 0 0 2array >>pos + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + 0 0 0 1 >>myc + 0 0 0 1 >>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 } ] 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 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 >>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 } ] 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 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 >>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 >>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 } ] 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 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 } ] 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 ] map >muons + 1300 [ drop ] map >quarks + 1000 [ drop ] map >hadrons + 111 [ drop ] 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 \ No newline at end of file diff --git a/extra/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor new file mode 100644 index 0000000000..f0a8889fbf --- /dev/null +++ b/extra/processing/gallery/trails/trails.factor @@ -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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 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 \ No newline at end of file diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor new file mode 100644 index 0000000000..acad02363b --- /dev/null +++ b/extra/processing/processing.factor @@ -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 + + + 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 ; \ No newline at end of file diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 5b835cd52f..39ee85b07a 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -26,8 +26,7 @@ M: pair make-disassemble-cmd M: method-spec make-disassemble-cmd first2 method make-disassemble-cmd ; -: gdb-binary ( -- string ) - os freebsd? "gdb66" "gdb" ? ; +: gdb-binary ( -- string ) "gdb" ; : run-gdb ( -- lines ) diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor new file mode 100644 index 0000000000..4990254778 --- /dev/null +++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor @@ -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]" + >>pixels ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: ( -- 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 * ] 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 ; + diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 52c3d2de42..91f7b0ec5d 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words prettyprint listener debugger threads boxes concurrency.flags -math arrays generic accessors ; +math arrays generic accessors combinators ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- ) : clear-stack ( 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 - >r "method-generic" word-prop r> word-completion-string ; + "method-generic" word-prop word-completion-string ; USE: generic.standard.engines.tuple 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 ) - >r [ word-name ] [ word-vocabulary ] bi dup vocab-words r> - input>> interactor-use memq? - [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ; +: use-if-necessary ( word seq -- ) + >r word-vocabulary vocab-words r> + { + { [ dup not ] [ 2drop ] } + { [ 2dup memq? ] [ 2drop ] } + { [ t ] [ push ] } + } cond ; : insert-word ( word -- ) - get-workspace - workspace-listener - [ word-completion-string ] keep - input>> user-input ; + get-workspace workspace-listener input>> + [ >r word-completion-string r> user-input ] + [ interactor-use use-if-necessary ] + 2bi ; : quot-action ( interactor -- lines ) dup control-value diff --git a/vm/errors.c b/vm/errors.c index 27158cbf44..6d99d34766 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear) { throw_impl(dpop(),stack_chain->callstack_bottom); } + +/* For testing purposes */ +DEFINE_PRIMITIVE(unimplemented) +{ + not_implemented_error(); +} diff --git a/vm/errors.h b/vm/errors.h index 747a3415ba..227fed9228 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -55,3 +55,5 @@ void *signal_callstack_top; void memory_signal_handler_impl(void); void divide_by_zero_signal_handler_impl(void); void misc_signal_handler_impl(void); + +DECLARE_PRIMITIVE(unimplemented); diff --git a/vm/errors.s b/vm/errors.s new file mode 100644 index 0000000000..d6b3bdb6e5 --- /dev/null +++ b/vm/errors.s @@ -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" diff --git a/vm/os-windows.c b/vm/os-windows.c index 1be41f8b57..664df9e774 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -215,7 +215,7 @@ void sleep_millis(DWORD msec) Sleep(msec); } -DECLARE_PRIMITIVE(set_os_envs) +DEFINE_PRIMITIVE(set_os_envs) { not_implemented_error(); } diff --git a/vm/primitives.c b/vm/primitives.c index 038a7d84a5..533fcebc9a 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -187,4 +187,5 @@ void *primitives[] = { primitive_resize_bit_array, primitive_resize_float_array, primitive_dll_validp, + primitive_unimplemented, }; diff --git a/vm/run.s b/vm/run.s new file mode 100644 index 0000000000..78b2adac84 --- /dev/null +++ b/vm/run.s @@ -0,0 +1,1511 @@ + .file "run.c" + .text +.globl _reset_datastack + .def _reset_datastack; .scl 2; .type 32; .endef +_reset_datastack: + pushl %ebp + movl %esp, %ebp + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %esi + subl $4, %esi + popl %ebp + ret +.globl _reset_retainstack + .def _reset_retainstack; .scl 2; .type 32; .endef +_reset_retainstack: + pushl %ebp + movl %esp, %ebp + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %edi + subl $4, %edi + popl %ebp + ret +.globl _fix_stacks + .def _fix_stacks; .scl 2; .type 32; .endef +_fix_stacks: + pushl %ebp + movl %esp, %ebp + leal 4(%esi), %eax + movl _stack_chain, %edx + movl 24(%edx), %edx + cmpl (%edx), %eax + jb L5 + leal 256(%esi), %eax + movl _stack_chain, %edx + movl 24(%edx), %edx + cmpl 8(%edx), %eax + jae L5 + jmp L4 +L5: + call _reset_datastack +L4: + leal 4(%edi), %eax + movl _stack_chain, %edx + movl 28(%edx), %edx + cmpl (%edx), %eax + jb L7 + leal 256(%edi), %eax + movl _stack_chain, %edx + movl 28(%edx), %edx + cmpl 8(%edx), %eax + jae L7 + jmp L3 +L7: + call _reset_retainstack +L3: + popl %ebp + ret +.globl _save_stacks + .def _save_stacks; .scl 2; .type 32; .endef +_save_stacks: + pushl %ebp + movl %esp, %ebp + cmpl $0, _stack_chain + je L8 + movl _stack_chain, %eax + movl %esi, 8(%eax) + movl _stack_chain, %eax + movl %edi, 12(%eax) +L8: + popl %ebp + ret +.globl _nest_stacks + .def _nest_stacks; .scl 2; .type 32; .endef +_nest_stacks: + pushl %ebp + movl %esp, %ebp + pushl %ebx + subl $20, %esp + movl $44, (%esp) + call _safe_malloc + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl $-1, 4(%eax) + movl -8(%ebp), %eax + movl $-1, (%eax) + movl -8(%ebp), %eax + movl %esi, 16(%eax) + movl -8(%ebp), %eax + movl %edi, 20(%eax) + movl -8(%ebp), %edx + movl _userenv+8, %eax + movl %eax, 36(%edx) + movl -8(%ebp), %edx + movl _userenv+4, %eax + movl %eax, 32(%edx) + movl -8(%ebp), %ebx + movl _ds_size, %eax + movl %eax, (%esp) + call _alloc_segment + movl %eax, 24(%ebx) + movl -8(%ebp), %ebx + movl _rs_size, %eax + movl %eax, (%esp) + call _alloc_segment + movl %eax, 28(%ebx) + movl -8(%ebp), %edx + movl _stack_chain, %eax + movl %eax, 40(%edx) + movl -8(%ebp), %eax + movl %eax, _stack_chain + call _reset_datastack + call _reset_retainstack + addl $20, %esp + popl %ebx + popl %ebp + ret +.globl _unnest_stacks + .def _unnest_stacks; .scl 2; .type 32; .endef +_unnest_stacks: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl _stack_chain, %eax + movl 24(%eax), %eax + movl %eax, (%esp) + call _dealloc_segment + movl _stack_chain, %eax + movl 28(%eax), %eax + movl %eax, (%esp) + call _dealloc_segment + movl _stack_chain, %eax + movl 16(%eax), %esi + movl _stack_chain, %eax + movl 20(%eax), %edi + movl _stack_chain, %eax + movl 36(%eax), %eax + movl %eax, _userenv+8 + movl _stack_chain, %eax + movl 32(%eax), %eax + movl %eax, _userenv+4 + movl _stack_chain, %eax + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl 40(%eax), %eax + movl %eax, _stack_chain + movl -4(%ebp), %eax + movl %eax, (%esp) + call _free + leave + ret +.globl _init_stacks + .def _init_stacks; .scl 2; .type 32; .endef +_init_stacks: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl %eax, _ds_size + movl 12(%ebp), %eax + movl %eax, _rs_size + movl $0, _stack_chain + popl %ebp + ret +.globl _primitive_drop + .def _primitive_drop; .scl 2; .type 32; .endef +_primitive_drop: + 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_drop_impl + leave + ret + .def _primitive_drop_impl; .scl 3; .type 32; .endef +_primitive_drop_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + 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_2drop + .def _primitive_2drop; .scl 2; .type 32; .endef +_primitive_2drop: + 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_2drop_impl + leave + ret + .def _primitive_2drop_impl; .scl 3; .type 32; .endef +_primitive_2drop_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esi + popl %ebp + ret +.globl _primitive_3drop + .def _primitive_3drop; .scl 2; .type 32; .endef +_primitive_3drop: + 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_3drop_impl + leave + ret + .def _primitive_3drop_impl; .scl 3; .type 32; .endef +_primitive_3drop_impl: + pushl %ebp + movl %esp, %ebp + subl $12, %esi + popl %ebp + ret +.globl _primitive_dup + .def _primitive_dup; .scl 2; .type 32; .endef +_primitive_dup: + 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_dup_impl + leave + ret + .def _primitive_dup_impl; .scl 3; .type 32; .endef +_primitive_dup_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + movl %eax, (%esp) + call _dpush + 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 + .def _dpeek; .scl 3; .type 32; .endef +_dpeek: + pushl %ebp + movl %esp, %ebp + subl $4, %esp + movl %esi, (%esp) + call _get + leave + ret +.globl _primitive_2dup + .def _primitive_2dup; .scl 2; .type 32; .endef +_primitive_2dup: + 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_2dup_impl + leave + ret + .def _primitive_2dup_impl; .scl 3; .type 32; .endef +_primitive_2dup_impl: + pushl %ebp + movl %esp, %ebp + subl $16, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + addl $8, %esi + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret +.globl _primitive_3dup + .def _primitive_3dup; .scl 2; .type 32; .endef +_primitive_3dup: + 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_3dup_impl + leave + ret + .def _primitive_3dup_impl; .scl 3; .type 32; .endef +_primitive_3dup_impl: + pushl %ebp + movl %esp, %ebp + subl $20, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -12(%ebp) + addl $12, %esi + movl -4(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -12(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_rot + .def _primitive_rot; .scl 2; .type 32; .endef +_primitive_rot: + 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_rot_impl + leave + ret + .def _primitive_rot_impl; .scl 3; .type 32; .endef +_primitive_rot_impl: + pushl %ebp + movl %esp, %ebp + subl $20, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -12(%ebp) + movl -12(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive__rot + .def _primitive__rot; .scl 2; .type 32; .endef +_primitive__rot: + 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__rot_impl + leave + ret + .def _primitive__rot_impl; .scl 3; .type 32; .endef +_primitive__rot_impl: + pushl %ebp + movl %esp, %ebp + subl $20, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -12(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -12(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_dupd + .def _primitive_dupd; .scl 2; .type 32; .endef +_primitive_dupd: + 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_dupd_impl + leave + ret + .def _primitive_dupd_impl; .scl 3; .type 32; .endef +_primitive_dupd_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_swapd + .def _primitive_swapd; .scl 2; .type 32; .endef +_primitive_swapd: + 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_swapd_impl + leave + ret + .def _primitive_swapd_impl; .scl 3; .type 32; .endef +_primitive_swapd_impl: + pushl %ebp + movl %esp, %ebp + subl $16, %esp + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -4(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_nip + .def _primitive_nip; .scl 2; .type 32; .endef +_primitive_nip: + 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_nip_impl + leave + ret + .def _primitive_nip_impl; .scl 3; .type 32; .endef +_primitive_nip_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl %eax, (%esp) + call _drepl + leave + ret + .def _drepl; .scl 3; .type 32; .endef +_drepl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret +.globl _primitive_2nip + .def _primitive_2nip; .scl 2; .type 32; .endef +_primitive_2nip: + 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_2nip_impl + leave + ret + .def _primitive_2nip_impl; .scl 3; .type 32; .endef +_primitive_2nip_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + movl %eax, -4(%ebp) + subl $8, %esi + movl -4(%ebp), %eax + movl %eax, (%esp) + call _drepl + leave + ret +.globl _primitive_tuck + .def _primitive_tuck; .scl 2; .type 32; .endef +_primitive_tuck: + 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_tuck_impl + leave + ret + .def _primitive_tuck_impl; .scl 3; .type 32; .endef +_primitive_tuck_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_over + .def _primitive_over; .scl 2; .type 32; .endef +_primitive_over: + 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_over_impl + leave + ret + .def _primitive_over_impl; .scl 3; .type 32; .endef +_primitive_over_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_pick + .def _primitive_pick; .scl 2; .type 32; .endef +_primitive_pick: + 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_pick_impl + leave + ret + .def _primitive_pick_impl; .scl 3; .type 32; .endef +_primitive_pick_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_swap + .def _primitive_swap; .scl 2; .type 32; .endef +_primitive_swap: + 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_swap_impl + leave + ret + .def _primitive_swap_impl; .scl 3; .type 32; .endef +_primitive_swap_impl: + pushl %ebp + movl %esp, %ebp + subl $16, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_to_r + .def _primitive_to_r; .scl 2; .type 32; .endef +_primitive_to_r: + 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_to_r_impl + leave + ret + .def _primitive_to_r_impl; .scl 3; .type 32; .endef +_primitive_to_r_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _rpush + leave + ret + .def _rpush; .scl 3; .type 32; .endef +_rpush: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + addl $4, %edi + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %edi, (%esp) + call _put + leave + ret +.globl _primitive_from_r + .def _primitive_from_r; .scl 2; .type 32; .endef +_primitive_from_r: + 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_from_r_impl + leave + ret + .def _primitive_from_r_impl; .scl 3; .type 32; .endef +_primitive_from_r_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _rpop + movl %eax, (%esp) + call _dpush + leave + ret + .def _rpop; .scl 3; .type 32; .endef +_rpop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %edi, (%esp) + call _get + movl %eax, -4(%ebp) + subl $4, %edi + movl -4(%ebp), %eax + leave + ret +.globl _stack_to_array + .def _stack_to_array; .scl 2; .type 32; .endef +_stack_to_array: + pushl %ebp + movl %esp, %ebp + subl $40, %esp + movl 8(%ebp), %edx + movl 12(%ebp), %eax + subl %edx, %eax + addl $4, %eax + movl %eax, -4(%ebp) + cmpl $0, -4(%ebp) + jns L58 + movl $0, -12(%ebp) + jmp L57 +L58: + movl -4(%ebp), %eax + movl %eax, -16(%ebp) + cmpl $0, -16(%ebp) + jns L60 + addl $3, -16(%ebp) +L60: + movl -16(%ebp), %eax + sarl $2, %eax + movl %eax, 4(%esp) + movl $8, (%esp) + call _allot_array_internal + movl %eax, -8(%ebp) + movl -4(%ebp), %eax + movl %eax, 8(%esp) + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl -8(%ebp), %eax + addl $8, %eax + movl %eax, (%esp) + call _memcpy + movl -8(%ebp), %eax + movl %eax, (%esp) + call _tag_object + movl %eax, (%esp) + call _dpush + movl $1, -12(%ebp) +L57: + movl -12(%ebp), %eax + leave + ret + .def _tag_object; .scl 3; .type 32; .endef +_tag_object: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + andl $-8, %eax + orl $3, %eax + popl %ebp + ret +.globl _primitive_datastack + .def _primitive_datastack; .scl 2; .type 32; .endef +_primitive_datastack: + 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_datastack_impl + leave + ret + .def _primitive_datastack_impl; .scl 3; .type 32; .endef +_primitive_datastack_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl %esi, 4(%esp) + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, (%esp) + call _stack_to_array + testb %al, %al + jne L63 + movl $0, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $11, (%esp) + call _general_error +L63: + leave + ret +.globl _primitive_retainstack + .def _primitive_retainstack; .scl 2; .type 32; .endef +_primitive_retainstack: + 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_retainstack_impl + leave + ret + .def _primitive_retainstack_impl; .scl 3; .type 32; .endef +_primitive_retainstack_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl %edi, 4(%esp) + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, (%esp) + call _stack_to_array + testb %al, %al + jne L66 + movl $0, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $13, (%esp) + call _general_error +L66: + leave + ret +.globl _array_to_stack + .def _array_to_stack; .scl 2; .type 32; .endef +_array_to_stack: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, (%esp) + call _array_capacity + sall $2, %eax + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl %eax, 8(%esp) + movl 8(%ebp), %eax + addl $8, %eax + movl %eax, 4(%esp) + movl 12(%ebp), %eax + movl %eax, (%esp) + call _memcpy + movl -4(%ebp), %eax + addl 12(%ebp), %eax + subl $4, %eax + leave + ret + .def _array_capacity; .scl 3; .type 32; .endef +_array_capacity: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl 4(%eax), %eax + shrl $3, %eax + popl %ebp + ret +.globl _primitive_set_datastack + .def _primitive_set_datastack; .scl 2; .type 32; .endef +_primitive_set_datastack: + 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_set_datastack_impl + leave + ret + .def _primitive_set_datastack_impl; .scl 3; .type 32; .endef +_primitive_set_datastack_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _untag_array + movl %eax, %edx + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl %edx, (%esp) + call _array_to_stack + movl %eax, %esi + leave + ret + .def _untag_array; .scl 3; .type 32; .endef +_untag_array: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl $8, (%esp) + call _type_check + movl 8(%ebp), %eax + movl %eax, (%esp) + call _untag_object + leave + ret + .def _untag_object; .scl 3; .type 32; .endef +_untag_object: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + andl $-8, %eax + popl %ebp + ret + .def _type_check; .scl 3; .type 32; .endef +_type_check: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 12(%ebp), %eax + movl %eax, (%esp) + call _type_of + cmpl 8(%ebp), %eax + je L74 + movl 12(%ebp), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _type_error +L74: + leave + ret + .def _type_of; .scl 3; .type 32; .endef +_type_of: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + andl $7, %eax + movl %eax, -4(%ebp) + cmpl $3, -4(%ebp) + jne L77 + movl 8(%ebp), %eax + movl %eax, (%esp) + call _object_type + movl %eax, -8(%ebp) + jmp L76 +L77: + movl -4(%ebp), %eax + movl %eax, -8(%ebp) +L76: + movl -8(%ebp), %eax + leave + ret + .def _object_type; .scl 3; .type 32; .endef +_object_type: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 8(%ebp), %eax + andl $-8, %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _untag_header + leave + ret + .def _untag_header; .scl 3; .type 32; .endef +_untag_header: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + shrl $3, %eax + popl %ebp + ret +.globl _primitive_set_retainstack + .def _primitive_set_retainstack; .scl 2; .type 32; .endef +_primitive_set_retainstack: + 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_set_retainstack_impl + leave + ret + .def _primitive_set_retainstack_impl; .scl 3; .type 32; .endef +_primitive_set_retainstack_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _untag_array + movl %eax, %edx + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl %edx, (%esp) + call _array_to_stack + movl %eax, %edi + leave + ret +.globl _primitive_getenv + .def _primitive_getenv; .scl 2; .type 32; .endef +_primitive_getenv: + 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_getenv_impl + leave + ret + .def _primitive_getenv_impl; .scl 3; .type 32; .endef +_primitive_getenv_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl _userenv(,%eax,4), %eax + movl %eax, (%esp) + call _drepl + leave + ret + .def _untag_fixnum_fast; .scl 3; .type 32; .endef +_untag_fixnum_fast: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + sarl $3, %eax + popl %ebp + ret +.globl _primitive_setenv + .def _primitive_setenv; .scl 2; .type 32; .endef +_primitive_setenv: + 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_setenv_impl + leave + ret + .def _primitive_setenv_impl; .scl 3; .type 32; .endef +_primitive_setenv_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + call _dpop + movl %eax, -8(%ebp) + movl -4(%ebp), %edx + movl -8(%ebp), %eax + movl %eax, _userenv(,%edx,4) + leave + ret +.globl _primitive_exit + .def _primitive_exit; .scl 2; .type 32; .endef +_primitive_exit: + 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_exit_impl + leave + ret + .def _primitive_exit_impl; .scl 3; .type 32; .endef +_primitive_exit_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _to_fixnum + movl %eax, (%esp) + call _exit +.globl _primitive_os_env + .def _primitive_os_env; .scl 2; .type 32; .endef +_primitive_os_env: + 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_os_env_impl + leave + ret + .def _primitive_os_env_impl; .scl 3; .type 32; .endef +_primitive_os_env_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _unbox_char_string + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl %eax, (%esp) + call _getenv + movl %eax, -8(%ebp) + cmpl $0, -8(%ebp) + jne L92 + movl $7, (%esp) + call _dpush + jmp L91 +L92: + movl -8(%ebp), %eax + movl %eax, (%esp) + call _box_char_string +L91: + leave + ret +.globl _primitive_eq + .def _primitive_eq; .scl 2; .type 32; .endef +_primitive_eq: + 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_eq_impl + leave + ret + .def _primitive_eq_impl; .scl 3; .type 32; .endef +_primitive_eq_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, -4(%ebp) + call _dpeek + movl %eax, -8(%ebp) + movl -4(%ebp), %eax + cmpl -8(%ebp), %eax + jne L96 + movl _T, %eax + movl %eax, -12(%ebp) + jmp L97 +L96: + movl $7, -12(%ebp) +L97: + movl -12(%ebp), %eax + movl %eax, (%esp) + call _drepl + leave + ret +.globl _primitive_millis + .def _primitive_millis; .scl 2; .type 32; .endef +_primitive_millis: + 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_millis_impl + leave + ret + .def _primitive_millis_impl; .scl 3; .type 32; .endef +_primitive_millis_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _current_millis + movl %eax, (%esp) + movl %edx, 4(%esp) + call _box_unsigned_8 + leave + ret +.globl _primitive_sleep + .def _primitive_sleep; .scl 2; .type 32; .endef +_primitive_sleep: + 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_sleep_impl + leave + ret + .def _primitive_sleep_impl; .scl 3; .type 32; .endef +_primitive_sleep_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _to_cell + movl %eax, (%esp) + call _sleep_millis + leave + ret +.globl _primitive_tag + .def _primitive_tag; .scl 2; .type 32; .endef +_primitive_tag: + 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_tag_impl + leave + ret + .def _primitive_tag_impl; .scl 3; .type 32; .endef +_primitive_tag_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + andl $7, %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, (%esp) + call _drepl + 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 _primitive_slot + .def _primitive_slot; .scl 2; .type 32; .endef +_primitive_slot: + 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_slot_impl + leave + ret + .def _primitive_slot_impl; .scl 3; .type 32; .endef +_primitive_slot_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + call _dpop + movl %eax, -8(%ebp) + movl -8(%ebp), %edx + andl $-8, %edx + movl -4(%ebp), %eax + sall $2, %eax + leal (%edx,%eax), %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_set_slot + .def _primitive_set_slot; .scl 2; .type 32; .endef +_primitive_set_slot: + 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_set_slot_impl + leave + ret + .def _primitive_set_slot_impl; .scl 3; .type 32; .endef +_primitive_set_slot_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + call _dpop + movl %eax, -8(%ebp) + call _dpop + movl %eax, -12(%ebp) + movl -12(%ebp), %eax + movl %eax, 8(%esp) + movl -4(%ebp), %eax + movl %eax, 4(%esp) + movl -8(%ebp), %eax + movl %eax, (%esp) + call _set_slot + leave + ret + .def _set_slot; .scl 3; .type 32; .endef +_set_slot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 16(%ebp), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %edx + andl $-8, %edx + movl 12(%ebp), %eax + sall $2, %eax + leal (%edx,%eax), %eax + movl %eax, (%esp) + call _put + movl 8(%ebp), %eax + movl %eax, (%esp) + call _write_barrier + leave + ret + .def _write_barrier; .scl 3; .type 32; .endef +_write_barrier: + pushl %ebp + movl %esp, %ebp + subl $4, %esp + movl 8(%ebp), %eax + shrl $6, %eax + addl _cards_offset, %eax + movl %eax, -4(%ebp) + movl -4(%ebp), %edx + movl -4(%ebp), %eax + movzbl (%eax), %eax + orb $-64, %al + movb %al, (%edx) + 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 _sleep_millis; .scl 3; .type 32; .endef + .def _current_millis; .scl 3; .type 32; .endef + .def _getenv; .scl 3; .type 32; .endef + .def _exit; .scl 3; .type 32; .endef + .def _general_error; .scl 3; .type 32; .endef + .def _memcpy; .scl 3; .type 32; .endef + .def _allot_array_internal; .scl 3; .type 32; .endef + .def _save_callstack_top; .scl 3; .type 32; .endef + .def _free; .scl 3; .type 32; .endef + .def _dealloc_segment; .scl 3; .type 32; .endef + .def _alloc_segment; .scl 3; .type 32; .endef + .def _safe_malloc; .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" + .ascii " -export:unnest_stacks" + .ascii " -export:nest_stacks" + .ascii " -export:save_stacks"