] extend ;
: init-stars ( -- )
+ #! Generate random background of scrolling stars.
[ ] star-count [ random-star swons ] times stars set ;
: draw-stars ( -- )
] ;
: word-attrs ( word -- attrs )
- dup defined? [
- dup >r
- word-link dup >r "object-link" swons r>
+ #! Words without a vocabulary do not get a link or an action
+ #! popup.
+ dup word-vocabulary [
+ word-link [ "object-link" swons ] keep
word-actions <actions> "actions" swons
t "underline" swons
3list
- r>
] [
- [ ] swap
- ] ifte word-style append ;
+ drop [ ]
+ ] ifte ;
: prettyprint-word ( word -- )
- dup word-name swap word-attrs write-attr ;
+ dup word-name
+ swap dup word-attrs swap word-style append
+ write-attr ;
: prettyprint-object ( indent obj -- indent )
unparse write ;
[ 2 ] [ 5 "x" /@ "x" get ] unit-test
[ 1 ] [ "x" pred@ "x" get ] unit-test
[ 2 ] [ "x" succ@ "x" get ] unit-test
-[ 7 ] [ -3 "x" set 10 "x" rem@ ] unit-test
-[ -3 ] [ -3 "x" set 10 "x" rem@ ] unit-test
+[ 7 ] [ -3 "x" set 10 "x" rem@ "x" get ] unit-test
+[ -3 ] [ -3 "x" set 10 "x" mod@ "x" get ] unit-test
USE: prettyprint
USE: test
USE: words
+USE: stack
+[ ] [ gensym dup [ ] define-compound . ] unit-test
[ ] [ vocabs [ words [ see ] each ] each ] unit-test
cpu "x86" = [
[
"x86-compiler/simple"
+ "x86-compiler/stack"
"x86-compiler/ifte"
"x86-compiler/generic"
"x86-compiler/bail-out"
--- /dev/null
+IN: scratchpad
+USE: compiler
+USE: test
+USE: stack
+USE: words
+USE: combinators
+USE: lists
+
+! Make sure that stack ops compile to correct code.
+: compile-call ( quot -- word )
+ gensym [ swap define-compound ] keep dup compile execute ;
+
+[ ] [ 1 [ drop ] compile-call ] unit-test
+[ ] [ [ 1 drop ] compile-call ] unit-test
+[ ] [ [ 1 2 2drop ] compile-call ] unit-test
+[ ] [ 1 [ 2 2drop ] compile-call ] unit-test
+[ ] [ 1 2 [ 2drop ] compile-call ] unit-test
+[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
+[ 1 1 ] [ [ 1 dup ] compile-call ] unit-test