Update contributed code I wrote, plus dlists written by eiz, to use if instead of ifte.
Chris Double
parent
6c133f3d94
commit
c6d9341f13
|
|
@ -40,7 +40,7 @@ USING: concurrency kernel io lists threads math sequences namespaces unparser pr
|
|||
"pong" swap send (pong-server0)
|
||||
] [
|
||||
"Pong server shutting down" swap send
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: pong-server0 ( -- process)
|
||||
[ (pong-server0) ] spawn ;
|
||||
|
|
@ -172,7 +172,7 @@ C: promised-label ( promise -- promised-label )
|
|||
?promise
|
||||
] [
|
||||
drop "Unfulfilled Promise"
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
M: promised-label pref-dim ( promised-label - dim )
|
||||
dup promised-label-text label-size ;
|
||||
|
|
@ -182,7 +182,7 @@ M: promised-label draw-gadget* ( promised-label -- )
|
|||
dup promised-label-text draw-string ;
|
||||
|
||||
: fib ( n -- n )
|
||||
yield dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] ifte ;
|
||||
yield dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
|
||||
|
||||
: test-promise-ui ( -- )
|
||||
<promise> dup <promised-label> gadget. [ 12 fib unparse swap fulfill ] cons spawn drop ;
|
||||
|
|
|
|||
|
|
@ -130,7 +130,7 @@ USING: kernel concurrency concurrency-examples threads vectors
|
|||
"received" reply
|
||||
] [
|
||||
drop f
|
||||
] ifte
|
||||
] if
|
||||
] spawn
|
||||
"sent" swap send-synchronous
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -36,10 +36,10 @@ USE: prettyprint
|
|||
swapd [ (dlist-unlink) ] keep dlist-node-data nip
|
||||
] [
|
||||
dlist-node-next (dlist-pop?)
|
||||
] ifte
|
||||
] if
|
||||
] [
|
||||
2drop f
|
||||
] ifte* ;
|
||||
] if* ;
|
||||
|
||||
: dlist-pop? ( pred dlist -- obj | f )
|
||||
#! Return first item in the dlist that when passed to the
|
||||
|
|
@ -55,10 +55,10 @@ USE: prettyprint
|
|||
2drop t
|
||||
] [
|
||||
dlist-node-next (dlist-pred?)
|
||||
] ifte
|
||||
] if
|
||||
] [
|
||||
drop f
|
||||
] ifte* ;
|
||||
] if* ;
|
||||
|
||||
: dlist-pred? ( pred dlist -- obj | f )
|
||||
#! Return true if any item in the dlist that when passed to the
|
||||
|
|
@ -237,7 +237,7 @@ TUPLE: tagged-message data from tag ;
|
|||
r> car call
|
||||
] [
|
||||
r> 2drop
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: recv ( forms -- )
|
||||
#! Get a message from the processes mailbox. Compare it against the
|
||||
|
|
@ -266,7 +266,7 @@ TUPLE: tagged-message data from tag ;
|
|||
tagged-message-tag =
|
||||
] [
|
||||
2drop f
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: send-synchronous ( message process -- reply )
|
||||
#! Sends a message to the process using the 'message'
|
||||
|
|
@ -337,7 +337,7 @@ SYMBOL: quit-cc
|
|||
<tagged-message> swap send
|
||||
] [
|
||||
r> drop 3drop
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: maybe-send-reply ( message pred quot -- )
|
||||
#! Same as !result but if false is returned from
|
||||
|
|
@ -351,10 +351,10 @@ SYMBOL: quit-cc
|
|||
<tagged-message> swap send
|
||||
] [
|
||||
2drop
|
||||
] ifte*
|
||||
] if*
|
||||
] [
|
||||
r> drop 3drop
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: server-cc ( -- cc | process)
|
||||
#! Captures the current continuation and returns the value.
|
||||
|
|
|
|||
|
|
@ -78,14 +78,14 @@ USE: namespaces
|
|||
: too-low "Too low" web-print ;
|
||||
: correct "Correct - you win!" web-print ;
|
||||
: inexact-guess ( actual guess -- )
|
||||
< [ too-high ] [ too-low ] ifte ;
|
||||
< [ too-high ] [ too-low ] if ;
|
||||
|
||||
: judge-guess ( actual guess -- ? )
|
||||
2dup = [
|
||||
2drop correct f
|
||||
] [
|
||||
inexact-guess t
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: number-to-guess ( -- n ) 0 100 random-int ;
|
||||
|
||||
|
|
@ -94,7 +94,7 @@ USE: namespaces
|
|||
numbers-game-loop
|
||||
] [
|
||||
drop
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: numbers-game number-to-guess numbers-game-loop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ USE: sequences
|
|||
#! Replace occurrences of single quotes with
|
||||
#! backslash quote.
|
||||
[
|
||||
[ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc [ % ] [ % ] ?ifte ] each
|
||||
[ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc [ % ] [ % ] ?if ] each
|
||||
] "" make ;
|
||||
|
||||
: make-eval-javascript ( string -- string )
|
||||
|
|
@ -119,10 +119,10 @@ USE: sequences
|
|||
"browser" "responder" set
|
||||
<table border= "1" table>
|
||||
<tr> <th colspan= "2" th> "Source" write </th> </tr>
|
||||
<tr> <td colspan= "2" td> [ [ parse ] catch [ "No such word" write ] [ car see ] ifte ] with-simple-html-output </td> </tr>
|
||||
<tr> <td colspan= "2" td> [ [ parse ] catch [ "No such word" write ] [ car see ] if ] with-simple-html-output </td> </tr>
|
||||
<tr> <th> "Apropos" write </th> <th> "Usages" write </th> </tr>
|
||||
<tr> <td valign= "top" td> [ apropos ] with-simple-html-output </td>
|
||||
<td valign= "top" td> [ [ parse ] catch [ "No such word" write ] [ car usages. ] ifte ] with-simple-html-output </td>
|
||||
<td valign= "top" td> [ [ parse ] catch [ "No such word" write ] [ car usages. ] if ] with-simple-html-output </td>
|
||||
</tr>
|
||||
</table>
|
||||
] bind ;
|
||||
|
|
@ -230,7 +230,7 @@ USE: sequences
|
|||
[
|
||||
run-eval-requester
|
||||
] catch
|
||||
dup [ show-message-page ] [ drop ] ifte
|
||||
dup [ show-message-page ] [ drop ] if
|
||||
] forever ;
|
||||
|
||||
"eval" [ [ ] "None" [ ] <evaluator> eval-responder ] install-cont-responder
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ USE: lists
|
|||
|
||||
: get-live-updater-js* ( stream -- string )
|
||||
#! Read all lines from the stream, creating a string of the result.
|
||||
dup stream-readln dup [ % "\n" % get-live-updater-js* ] [ drop stream-close ] ifte ;
|
||||
dup stream-readln dup [ % "\n" % get-live-updater-js* ] [ drop stream-close ] if ;
|
||||
|
||||
: get-live-updater-js ( filename -- string )
|
||||
#! Return the liveUpdater javascript code as a string.
|
||||
|
|
|
|||
|
|
@ -197,9 +197,9 @@ USE: sequences
|
|||
t
|
||||
] [
|
||||
f
|
||||
] ifte
|
||||
] ifte
|
||||
] ifte ;
|
||||
] if
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: replace-invalid-username-chars ( str -- str )
|
||||
#! Return a string with invalid username characters mapped to underscores.
|
||||
|
|
@ -207,7 +207,7 @@ USE: sequences
|
|||
dup valid-username-char [
|
||||
] [
|
||||
drop CHAR: _
|
||||
] ifte
|
||||
] if
|
||||
] map ;
|
||||
|
||||
: is-valid-username? ( username -- bool )
|
||||
|
|
@ -260,7 +260,7 @@ USE: sequences
|
|||
] [
|
||||
<todo> init-new-todo
|
||||
"You have successfully registered your todo list." show-message-page
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: login-request-paragraph ( -- )
|
||||
#! Display the paragraph requesting the user to login or register.
|
||||
|
|
@ -334,11 +334,11 @@ USE: sequences
|
|||
: priority-valid? ( string -- bool )
|
||||
#! Test the string containing a priority to see if it is
|
||||
#! valid. It should be a single digit from 0-9.
|
||||
dup length 1 = [ 0 swap nth digit? ] [ drop f ] ifte ;
|
||||
dup length 1 = [ 0 swap nth digit? ] [ drop f ] if ;
|
||||
|
||||
: todo-details-valid? ( priority description -- bool )
|
||||
#! Return true if a valid priority and description were entered.
|
||||
length 0 > [ priority-valid? ] [ drop f ] ifte ;
|
||||
length 0 > [ priority-valid? ] [ drop f ] if ;
|
||||
|
||||
: get-new-todo-item ( -- <todo-item> )
|
||||
#! Enter a new item to the current todo list.
|
||||
|
|
@ -352,7 +352,7 @@ USE: sequences
|
|||
2drop
|
||||
"Please ensure you enter a Priority from 0-9 and a description." show-message-page
|
||||
get-new-todo-item
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: write-get-password-form ( url -- )
|
||||
#! Display the HTML for a form allowing entry of a
|
||||
|
|
@ -388,11 +388,11 @@ USE: sequences
|
|||
] [
|
||||
"Your new password did not match. The password was NOT changed." show-message-page
|
||||
f
|
||||
] ifte
|
||||
] if
|
||||
] [
|
||||
"You entered an incorrect old password. The password was NOT changed." show-message-page
|
||||
f
|
||||
] ifte
|
||||
] if
|
||||
] bind ;
|
||||
|
||||
: edit-item-details ( item -- )
|
||||
|
|
@ -407,7 +407,7 @@ USE: sequences
|
|||
drop drop
|
||||
"Please ensure you enter a Priority from 0-9 and a description." show-message-page
|
||||
edit-item-details
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: save-current-todo ( -- )
|
||||
#! Save the current todo list
|
||||
|
|
@ -426,7 +426,7 @@ USE: sequences
|
|||
"Delete" swap [ "todo" get swap delete-item save-current-todo ] lcurry1 quot-href
|
||||
] [
|
||||
"Complete" swap [ set-item-completed save-current-todo ] lcurry1 quot-href
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: write-edit-action ( item -- )
|
||||
#! Write out html to allow editing an item.
|
||||
|
|
@ -435,14 +435,14 @@ USE: sequences
|
|||
: item-class ( <todo-item> -- string )
|
||||
#! Return the class to use for displaying the row for the
|
||||
#! item.
|
||||
item-complete? [ "complete" ] [ "item" ] ifte ;
|
||||
item-complete? [ "complete" ] [ "item" ] if ;
|
||||
|
||||
: write-item-row ( <todo-item> -- )
|
||||
#! Write the todo list item as an HTML row.
|
||||
dup dup dup dup
|
||||
dup item-class [
|
||||
[ item-priority write ]
|
||||
[ item-complete? [ "Yes" ] [ "No" ] ifte write ]
|
||||
[ item-complete? [ "Yes" ] [ "No" ] if write ]
|
||||
[ item-description write ]
|
||||
[ write-mark-complete-action ]
|
||||
[ write-edit-action ]
|
||||
|
|
@ -468,7 +468,7 @@ USE: sequences
|
|||
"Your password has been changed." show-message-page
|
||||
] [
|
||||
drop
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: show-todo-list ( -- )
|
||||
#! Show the current todo list.
|
||||
|
|
|
|||
|
|
@ -119,7 +119,7 @@ USE: unparser
|
|||
load-todo password-matches?
|
||||
] [
|
||||
2drop f
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: each-bind ( quot list -- )
|
||||
[ swap [ bind ] keep ] each drop ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ C: dlist-node
|
|||
[ dlist-last f <dlist-node> ] keep
|
||||
[ dlist-last [ dupd set-dlist-node-next ] when* ] keep
|
||||
2dup set-dlist-last
|
||||
dup dlist-first [ 2drop ] [ set-dlist-first ] ifte ;
|
||||
dup dlist-first [ 2drop ] [ set-dlist-first ] if ;
|
||||
|
||||
: dlist-empty? ( dlist -- ? )
|
||||
dlist-first f = ;
|
||||
|
|
@ -28,7 +28,7 @@ C: dlist-node
|
|||
] when*
|
||||
2dup swap dlist-first eq? [
|
||||
dlist-node-next swap set-dlist-first
|
||||
] [ 2drop ] ifte ;
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: (unlink-next) ( dlist dnode -- )
|
||||
dup dlist-node-next [
|
||||
|
|
@ -36,7 +36,7 @@ C: dlist-node
|
|||
] when*
|
||||
2dup swap dlist-last eq? [
|
||||
dlist-node-prev swap set-dlist-last
|
||||
] [ 2drop ] ifte ;
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: (dlist-unlink) ( dlist dnode -- )
|
||||
[ (unlink-prev) ] 2keep (unlink-next) ;
|
||||
|
|
@ -45,7 +45,7 @@ C: dlist-node
|
|||
[ dlist-first dlist-node-data ] keep dup dlist-first (dlist-unlink) ;
|
||||
|
||||
: dlist-pop-front ( dlist -- data )
|
||||
dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] ifte ;
|
||||
dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] if ;
|
||||
|
||||
: (dlist-each) ( quot dnode -- )
|
||||
[
|
||||
|
|
@ -53,7 +53,7 @@ C: dlist-node
|
|||
dlist-node-next (dlist-each)
|
||||
] [
|
||||
drop
|
||||
] ifte* ; inline
|
||||
] if* ; inline
|
||||
|
||||
: dlist-each ( dlist quot -- )
|
||||
swap dlist-first (dlist-each) ; inline
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@ DEFER: lnil
|
|||
[ , \ lcdr , , \ lmap , ] [ ] make delay >r
|
||||
[ , \ lcar , , \ call , ] [ ] make delay r>
|
||||
lcons
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: ltake ( n llist -- llist )
|
||||
#! Return a lazy list containing the first n items from
|
||||
|
|
@ -120,8 +120,8 @@ DEFER: lnil
|
|||
[ [ 1 - ] cons , \ call , , \ lcdr , \ ltake , ] [ ] make delay >r
|
||||
[ , \ lcar , ] [ ] make delay r>
|
||||
lcons
|
||||
] ifte
|
||||
] ifte ;
|
||||
] if
|
||||
] if ;
|
||||
|
||||
DEFER: lsubset
|
||||
TUPLE: lsubset-state llist pred ;
|
||||
|
|
@ -140,7 +140,7 @@ TUPLE: lsubset-state llist pred ;
|
|||
] [ ( state lcar -- )
|
||||
drop dup lsubset-state-llist lcdr over set-lsubset-state-llist
|
||||
(lsubset-car)
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: (lsubset-set-first-car) ( state -- bool )
|
||||
#! Set the state to the first valid car. If none found
|
||||
|
|
@ -154,8 +154,8 @@ TUPLE: lsubset-state llist pred ;
|
|||
] [
|
||||
over set-lsubset-state-llist
|
||||
(lsubset-set-first-car)
|
||||
] ifte
|
||||
] ifte ;
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: lsubset ( llist pred -- llist )
|
||||
#! Return a lazy list containing only the items from the original
|
||||
|
|
@ -170,8 +170,8 @@ TUPLE: lsubset-state llist pred ;
|
|||
[ (lsubset-car) ] cons delay r> lcons
|
||||
] [
|
||||
drop lnil
|
||||
] ifte
|
||||
] ifte ;
|
||||
] if
|
||||
] if ;
|
||||
|
||||
DEFER: lappend*
|
||||
DEFER: (lappend*)
|
||||
|
|
@ -193,11 +193,11 @@ USE: io
|
|||
nip
|
||||
luncons ( state rest-car rest-cdr -- )
|
||||
<lappend*-state> (lappend*)
|
||||
] ifte
|
||||
] if
|
||||
] [ ( state cdr -- )
|
||||
swap lappend*-state-rest <lappend*-state> (lappend*)
|
||||
] ifte
|
||||
] ifte ;
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: (lappend*-car) ( state -- value )
|
||||
#! Given the state object, do the car portion of the
|
||||
|
|
@ -206,7 +206,7 @@ USE: io
|
|||
nip
|
||||
] [ ( state current -- )
|
||||
lcar nip
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: (lappend*) ( state -- llist )
|
||||
#! Do the main work of the lazy list appending using a
|
||||
|
|
@ -238,7 +238,7 @@ DEFER: list>llist
|
|||
2drop
|
||||
] [
|
||||
>r luncons r> tuck >r >r call r> r> leach
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
|
||||
: (llist>list) ( result llist -- list )
|
||||
|
|
@ -248,7 +248,7 @@ DEFER: list>llist
|
|||
] [
|
||||
dup lcar ( result llist car )
|
||||
swap lcdr >r swons r> (llist>list)
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: llist>list ( llist -- list )
|
||||
#! Convert a lazy list to a normal list. This will cause
|
||||
|
|
@ -261,7 +261,7 @@ DEFER: list>llist
|
|||
uncons [ list>llist ] cons delay >r unit delay r> lcons
|
||||
] [
|
||||
drop lnil
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
! M: lcons nth lnth ;
|
||||
|
||||
|
|
|
|||
|
|
@ -98,14 +98,14 @@ M: list pempty? ( object -- bool )
|
|||
2drop ""
|
||||
] [
|
||||
head
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: (list-take) ( n list accum -- list )
|
||||
>r >r 1 - dup 0 < [
|
||||
drop r> drop r> reverse
|
||||
] [
|
||||
r> uncons swap r> cons (list-take)
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: list-take ( n list -- list )
|
||||
#! Return a list with the first 'n' characters
|
||||
|
|
@ -133,7 +133,7 @@ M: list ptake ( n object -- object )
|
|||
2drop ""
|
||||
] [
|
||||
tail
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: list-drop ( n list -- list )
|
||||
#! Return a list with the first 'n' items
|
||||
|
|
@ -142,7 +142,7 @@ M: list ptake ( n object -- object )
|
|||
drop r>
|
||||
] [
|
||||
r> cdr list-drop
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
GENERIC: pdrop
|
||||
|
||||
|
|
@ -165,7 +165,7 @@ M: list pdrop ( n object -- object )
|
|||
swap over length swap pdrop swons unit delay lunit
|
||||
] [
|
||||
2drop lnil
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: token ( string -- parser )
|
||||
#! Return a token parser that parses the given string.
|
||||
|
|
@ -182,8 +182,8 @@ M: list pdrop ( n object -- object )
|
|||
ph:t swons unit delay lunit
|
||||
] [
|
||||
drop lnil
|
||||
] ifte
|
||||
] ifte ;
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: satisfy ( p -- parser )
|
||||
#! Return a parser that succeeds if the predicate 'p',
|
||||
|
|
@ -202,7 +202,7 @@ M: list pdrop ( n object -- object )
|
|||
ph:t >r swap call r> swons unit delay lunit
|
||||
] [
|
||||
2drop lnil
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: satisfy2 ( pred quot -- parser )
|
||||
#! Return a satisfy2-parser.
|
||||
|
|
@ -322,7 +322,7 @@ M: list pdrop ( n object -- object )
|
|||
nip
|
||||
] [ ( quot result -- )
|
||||
[ (<@-parser-replace) ] rot swons lmap
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: <@ ( parser quot -- parser )
|
||||
#! Return an <@-parser.
|
||||
|
|
|
|||
|
|
@ -193,7 +193,7 @@ USING: kernel lazy parser-combinators test errors strings parser lists math sequ
|
|||
|
||||
: pdigit [ digit? ] satisfy [ digit> ] <@ ;
|
||||
: pnatural pdigit <*> ;
|
||||
: pnatural2 pnatural [ car [ >digit ] map >string dup pempty? [ drop 0 ] [ string>number ] ifte unit ] <@ ;
|
||||
: pnatural2 pnatural [ car [ >digit ] map >string dup pempty? [ drop 0 ] [ string>number ] if unit ] <@ ;
|
||||
|
||||
[
|
||||
[ "" 12345 ]
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
cpu-ram nth
|
||||
] [
|
||||
2drop HEX: FF
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: read-word ( addr cpu -- word )
|
||||
#! Read a 16-bit word from memory at the specified address.
|
||||
|
|
@ -141,7 +141,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
] [
|
||||
3dup cpu-ram set-nth
|
||||
update-video
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
|
||||
: write-word ( value addr cpu -- )
|
||||
|
|
@ -197,25 +197,25 @@ M: cpu write-port ( value port cpu -- )
|
|||
: update-zero-flag ( result cpu -- )
|
||||
#! If the result of an instruction has the value 0, this
|
||||
#! flag is set, otherwise it is reset.
|
||||
swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] ifte ;
|
||||
swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ;
|
||||
|
||||
: update-sign-flag ( result cpu -- )
|
||||
#! If the most significant bit of the result
|
||||
#! has the value 1 then the flag is set, otherwise
|
||||
#! it is reset.
|
||||
swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] ifte ;
|
||||
swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ;
|
||||
|
||||
: update-parity-flag ( result cpu -- )
|
||||
#! If the modulo 2 sum of the bits of the result
|
||||
#! is 0, (ie. if the result has even parity) this flag
|
||||
#! is set, otherwise it is reset.
|
||||
swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] ifte ;
|
||||
swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ;
|
||||
|
||||
: update-carry-flag ( result cpu -- )
|
||||
#! If the instruction resulted in a carry (from addition)
|
||||
#! or a borrow (from subtraction or a comparison) out of the
|
||||
#! higher order bit, this flag is set, otherwise it is reset.
|
||||
swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] ifte ;
|
||||
swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ;
|
||||
|
||||
: update-half-carry-flag ( original change-by result cpu -- )
|
||||
#! If the instruction caused a carry out of bit 3 and into bit 4 of the
|
||||
|
|
@ -224,7 +224,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
#! 'change-by' is the amount it is being added or decremented by.
|
||||
#! 'result' is the result of that change.
|
||||
>r bitxor bitxor HEX: 10 bitand 0 = not r>
|
||||
swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] ifte ;
|
||||
swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
|
||||
|
||||
: update-flags ( result cpu -- )
|
||||
2dup update-carry-flag
|
||||
|
|
@ -302,7 +302,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
: add-word ( lhs rhs cpu -- result )
|
||||
#! Add rhs to lhs. Note that only the carry flag is modified
|
||||
#! and only if there is a carry out of the double precision add.
|
||||
>r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] ifte HEX: FFFF bitand ;
|
||||
>r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
|
||||
|
||||
: bit3or ( lhs rhs -- 0|1 )
|
||||
#! bitor bit 3 of the two numbers on the stack
|
||||
|
|
@ -316,7 +316,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
[ drop bit3or ] 3keep ( bit3or lhs rhs cpu )
|
||||
>r bitand r> [ update-flags ] 2keep
|
||||
[ carry-flag clear-flag ] keep
|
||||
rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] ifte
|
||||
rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
|
||||
HEX: FF bitand ;
|
||||
|
||||
: xor-byte ( lhs rhs cpu -- result )
|
||||
|
|
@ -382,7 +382,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
set-cpu-pc
|
||||
] [
|
||||
2drop
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: inc-cycles ( n cpu -- )
|
||||
#! Increment the number of cpu cycles
|
||||
|
|
@ -422,7 +422,7 @@ instructions length [
|
|||
drop
|
||||
] [
|
||||
[ not-implemented ] swap instructions set-nth
|
||||
] ifte
|
||||
] if
|
||||
] each
|
||||
|
||||
M: cpu reset ( cpu -- )
|
||||
|
|
@ -450,7 +450,7 @@ C: cpu ( cpu -- cpu )
|
|||
-rot [ set-nth ] 2keep >r 1 + r> (load-rom)
|
||||
] [
|
||||
2drop
|
||||
] ifte* ;
|
||||
] if* ;
|
||||
|
||||
#! Reads the ROM from stdin and stores it in ROM from
|
||||
#! offset n.
|
||||
|
|
@ -482,7 +482,7 @@ C: cpu ( cpu -- cpu )
|
|||
nip
|
||||
] [
|
||||
[ "Undefined 8080 opcode: " % number>string % ] "" make throw
|
||||
] ifte* ;
|
||||
] if* ;
|
||||
|
||||
: process-interrupts ( cpu -- )
|
||||
#! Process any hardware interrupts
|
||||
|
|
@ -495,8 +495,8 @@ C: cpu ( cpu -- cpu )
|
|||
HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
|
||||
] [
|
||||
HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
|
||||
] ifte
|
||||
] ifte ;
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: step ( cpu -- )
|
||||
#! Run a single 8080 instruction
|
||||
|
|
@ -606,7 +606,7 @@ SYMBOL: $4
|
|||
dup $3 = [ drop 2 over nth ] when
|
||||
dup $4 = [ drop 3 over nth ] when
|
||||
nip
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: test-rp
|
||||
{ 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ;
|
||||
|
|
@ -631,20 +631,20 @@ SYMBOL: $4
|
|||
: (emulate-RLCA) ( cpu -- )
|
||||
#! The content of the accumulator is rotated left
|
||||
#! one position. The low order bit and the carry flag
|
||||
#! are both set to the value shifted out of the high
|
||||
#! are both set to the value shifd out of the high
|
||||
#! order bit position. Only the carry flag is affected.
|
||||
[ cpu-a -7 shift ] keep
|
||||
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] ifte
|
||||
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
||||
[ cpu-a 1 shift HEX: FF bitand ] keep
|
||||
>r bitor r> set-cpu-a ;
|
||||
|
||||
: (emulate-RRCA) ( cpu -- )
|
||||
#! The content of the accumulator is rotated right
|
||||
#! one position. The high order bit and the carry flag
|
||||
#! are both set to the value shifted out of the low
|
||||
#! are both set to the value shifd out of the low
|
||||
#! order bit position. Only the carry flag is affected.
|
||||
[ cpu-a 1 bitand 7 shift ] keep
|
||||
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] ifte
|
||||
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
||||
[ cpu-a 254 bitand -1 shift ] keep
|
||||
>r bitor r> set-cpu-a ;
|
||||
|
||||
|
|
@ -652,23 +652,23 @@ SYMBOL: $4
|
|||
#! The content of the accumulator is rotated left
|
||||
#! one position through the carry flag. The low
|
||||
#! order bit is set equal to the carry flag and
|
||||
#! the carry flag is set to the value shifted out
|
||||
#! the carry flag is set to the value shifd out
|
||||
#! of the high order bit. Only the carry flag is
|
||||
#! affected.
|
||||
[ carry-flag swap flag-set? [ 1 ] [ 0 ] ifte ] keep
|
||||
[ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
|
||||
[ cpu-a 127 bitand 7 shift ] keep
|
||||
dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] ifte
|
||||
dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
||||
>r bitor r> set-cpu-a ;
|
||||
|
||||
: (emulate-RRA) ( cpu -- )
|
||||
#! The content of the accumulator is rotated right
|
||||
#! one position through the carry flag. The high order
|
||||
#! bit is set to the carry flag and the carry flag is
|
||||
#! set to the value shifted out of the low order bit.
|
||||
#! set to the value shifd out of the low order bit.
|
||||
#! Only the carry flag is affected.
|
||||
[ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] ifte ] keep
|
||||
[ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
|
||||
[ cpu-a 254 bitand -1 shift ] keep
|
||||
dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] ifte
|
||||
dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
|
||||
>r bitor r> set-cpu-a ;
|
||||
|
||||
: (emulate-CPL) ( cpu -- )
|
||||
|
|
@ -683,14 +683,14 @@ SYMBOL: $4
|
|||
#! digits.
|
||||
[
|
||||
dup half-carry-flag swap flag-set? swap
|
||||
cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] ifte
|
||||
cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
|
||||
] keep
|
||||
[ cpu-a + ] keep
|
||||
[ update-flags ] 2keep
|
||||
[ swap HEX: FF bitand swap set-cpu-a ] keep
|
||||
[
|
||||
dup carry-flag swap flag-set? swap
|
||||
cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] ifte
|
||||
cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
|
||||
] keep
|
||||
[ cpu-a + ] keep
|
||||
[ update-flags ] 2keep
|
||||
|
|
@ -709,7 +709,7 @@ SYMBOL: $4
|
|||
[[ "RST-28H" [ HEX: 28 swap (emulate-RST) ] ]]
|
||||
[[ "RST-30H" [ HEX: 30 swap (emulate-RST) ] ]]
|
||||
[[ "RST-38H" [ HEX: 38 swap (emulate-RST) ] ]]
|
||||
[[ "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] ifte ] ]]
|
||||
[[ "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] ]]
|
||||
[[ "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] ]]
|
||||
[[ "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] ]]
|
||||
[[ "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] ]]
|
||||
|
|
@ -755,10 +755,10 @@ SYMBOL: $4
|
|||
[[ "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] ]]
|
||||
[[ "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] ]]
|
||||
[[ "JP-NN" [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ] ]]
|
||||
[[ "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] ifte ] ]]
|
||||
[[ "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] ]]
|
||||
[[ "JP-(RR)" [ [ $1 ] keep set-cpu-pc ] ]]
|
||||
[[ "CALL-NN" [ (emulate-CALL) ] ]]
|
||||
[[ "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] ifte ] ]]
|
||||
[[ "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] ]]
|
||||
[[ "LD-RR,NN" [ [ next-word ] keep $2 ] ]]
|
||||
[[ "LD-RR,RR" [ [ $3 ] keep $2 ] ]]
|
||||
[[ "LD-R,N" [ [ next-byte ] keep $2 ] ]]
|
||||
|
|
@ -1599,7 +1599,7 @@ INSTRUCTION: RST 38H ; opcode FF cycles 11
|
|||
" 0 0 0" write
|
||||
] [
|
||||
" 1 1 1" write
|
||||
] ifte
|
||||
] if
|
||||
] each-8bit
|
||||
] repeat terpri
|
||||
] repeat
|
||||
|
|
|
|||
|
|
@ -57,8 +57,8 @@ M: space-invaders reset ( cpu -- )
|
|||
HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
|
||||
] [
|
||||
HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
|
||||
] ifte
|
||||
] ifte ;
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: gui-frame ( cpu -- )
|
||||
dup gui-frame/2 gui-frame/2 ;
|
||||
|
|
@ -101,7 +101,7 @@ M: key-up-event handle-si-event ( cpu event -- quit? )
|
|||
|
||||
: sync-frame ( millis -- millis )
|
||||
#! Sleep until the time for the next frame arrives.
|
||||
1000 60 / >fixnum + millis - dup 0 > [ sleep ] [ drop ] ifte millis ;
|
||||
1000 60 / >fixnum + millis - dup 0 > [ sleep ] [ drop ] if millis ;
|
||||
|
||||
: (event-loop) ( millis cpu event -- )
|
||||
dup SDL_PollEvent [
|
||||
|
|
@ -109,12 +109,12 @@ M: key-up-event handle-si-event ( cpu event -- quit? )
|
|||
3drop
|
||||
] [
|
||||
(event-loop)
|
||||
] ifte
|
||||
] if
|
||||
] [
|
||||
>r >r sync-frame r> r>
|
||||
[ over gui-frame ] with-surface
|
||||
(event-loop)
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: event-loop ( cpu event -- )
|
||||
millis -rot (event-loop) ;
|
||||
|
|
@ -143,7 +143,7 @@ M: key-up-event handle-si-event ( cpu event -- quit? )
|
|||
- surface get -rot black rgb pixelColor
|
||||
] [
|
||||
- surface get -rot 2dup color rgb pixelColor
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: do-video-update ( value addr cpu -- )
|
||||
drop addr>xy rot ( x y value )
|
||||
|
|
@ -161,7 +161,7 @@ M: space-invaders update-video ( value addr cpu -- )
|
|||
do-video-update
|
||||
] [
|
||||
3drop
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: run ( -- )
|
||||
224 256 0 SDL_HWSURFACE [
|
||||
|
|
|
|||
|
|
@ -158,7 +158,7 @@ END-STRUCT
|
|||
drop
|
||||
] [
|
||||
"sqlite returned an error. See datastack for the error value." throw
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: sqlite-open ( filename -- db )
|
||||
#! Open the database referenced by the filename and return
|
||||
|
|
@ -214,8 +214,8 @@ END-STRUCT
|
|||
drop t
|
||||
] [
|
||||
sqlite-check-result t
|
||||
] ifte
|
||||
] ifte ;
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: sqlite-each ( statement quot -- )
|
||||
#! Execute the SQL statement, and call the quotation for
|
||||
|
|
@ -225,7 +225,7 @@ END-STRUCT
|
|||
2drop
|
||||
] [
|
||||
[ call ] 2keep sqlite-each
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
! For comparison, here is the linrec implementation of sqlite-each
|
||||
! [ drop sqlite3_step step-complete? ]
|
||||
|
|
@ -238,7 +238,7 @@ END-STRUCT
|
|||
2nip
|
||||
] [
|
||||
>r 2dup call r> cons (sqlite-map)
|
||||
] ifte ;
|
||||
] if ;
|
||||
|
||||
: sqlite-map ( statement quot -- )
|
||||
[ ] (sqlite-map) ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue