diff --git a/contrib/concurrency/concurrency-examples.factor b/contrib/concurrency/concurrency-examples.factor index 96e31e8662..184d437d6f 100644 --- a/contrib/concurrency/concurrency-examples.factor +++ b/contrib/concurrency/concurrency-examples.factor @@ -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 ( -- ) dup gadget. [ 12 fib unparse swap fulfill ] cons spawn drop ; diff --git a/contrib/concurrency/concurrency-tests.factor b/contrib/concurrency/concurrency-tests.factor index 498bffdc3a..e112b9b70d 100644 --- a/contrib/concurrency/concurrency-tests.factor +++ b/contrib/concurrency/concurrency-tests.factor @@ -130,7 +130,7 @@ USING: kernel concurrency concurrency-examples threads vectors "received" reply ] [ drop f - ] ifte + ] if ] spawn "sent" swap send-synchronous ] unit-test diff --git a/contrib/concurrency/concurrency.factor b/contrib/concurrency/concurrency.factor index 7de9930ac0..335302f4a3 100644 --- a/contrib/concurrency/concurrency.factor +++ b/contrib/concurrency/concurrency.factor @@ -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 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 swap send ] [ 2drop - ] ifte* + ] if* ] [ r> drop 3drop - ] ifte ; + ] if ; : server-cc ( -- cc | process) #! Captures the current continuation and returns the value. diff --git a/contrib/cont-responder/cont-numbers-game.factor b/contrib/cont-responder/cont-numbers-game.factor index 62e2474d25..a379efb86b 100644 --- a/contrib/cont-responder/cont-numbers-game.factor +++ b/contrib/cont-responder/cont-numbers-game.factor @@ -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 ; diff --git a/contrib/cont-responder/eval-responder.factor b/contrib/cont-responder/eval-responder.factor index de1c9e544b..b6a5ce4b81 100644 --- a/contrib/cont-responder/eval-responder.factor +++ b/contrib/cont-responder/eval-responder.factor @@ -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 - + - +
"Source" write
[ [ parse ] catch [ "No such word" write ] [ car see ] ifte ] with-simple-html-output
[ [ parse ] catch [ "No such word" write ] [ car see ] if ] with-simple-html-output
"Apropos" write "Usages" write
[ apropos ] with-simple-html-output [ [ parse ] catch [ "No such word" write ] [ car usages. ] ifte ] with-simple-html-output [ [ parse ] catch [ "No such word" write ] [ car usages. ] if ] with-simple-html-output
] 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" [ ] eval-responder ] install-cont-responder diff --git a/contrib/cont-responder/live-updater.factor b/contrib/cont-responder/live-updater.factor index 950a695f24..12021a6ae7 100644 --- a/contrib/cont-responder/live-updater.factor +++ b/contrib/cont-responder/live-updater.factor @@ -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. diff --git a/contrib/cont-responder/todo-example.factor b/contrib/cont-responder/todo-example.factor index adcb400e8f..4d77b4d20f 100644 --- a/contrib/cont-responder/todo-example.factor +++ b/contrib/cont-responder/todo-example.factor @@ -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 ] [ 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 ( -- ) #! 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 ( -- 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 ( -- ) #! 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. diff --git a/contrib/cont-responder/todo.factor b/contrib/cont-responder/todo.factor index 7b08bb2ea4..459079bb43 100644 --- a/contrib/cont-responder/todo.factor +++ b/contrib/cont-responder/todo.factor @@ -119,7 +119,7 @@ USE: unparser load-todo password-matches? ] [ 2drop f - ] ifte ; + ] if ; : each-bind ( quot list -- ) [ swap [ bind ] keep ] each drop ; diff --git a/contrib/dlists.factor b/contrib/dlists.factor index 67649f2c8f..7a125b16ee 100644 --- a/contrib/dlists.factor +++ b/contrib/dlists.factor @@ -17,7 +17,7 @@ C: dlist-node [ dlist-last f ] 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 diff --git a/contrib/parser-combinators/lazy.factor b/contrib/parser-combinators/lazy.factor index 0e0e435e2b..2ba6f89cfe 100644 --- a/contrib/parser-combinators/lazy.factor +++ b/contrib/parser-combinators/lazy.factor @@ -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*) - ] ifte + ] if ] [ ( state cdr -- ) swap lappend*-state-rest (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 ; diff --git a/contrib/parser-combinators/parser-combinators.factor b/contrib/parser-combinators/parser-combinators.factor index 2db044dba8..a7a593bacc 100644 --- a/contrib/parser-combinators/parser-combinators.factor +++ b/contrib/parser-combinators/parser-combinators.factor @@ -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. diff --git a/contrib/parser-combinators/tests.factor b/contrib/parser-combinators/tests.factor index 1bfe3d5c46..c2c856785d 100644 --- a/contrib/parser-combinators/tests.factor +++ b/contrib/parser-combinators/tests.factor @@ -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 ] diff --git a/contrib/space-invaders/cpu-8080.factor b/contrib/space-invaders/cpu-8080.factor index 47b93f0d16..5625e88df7 100644 --- a/contrib/space-invaders/cpu-8080.factor +++ b/contrib/space-invaders/cpu-8080.factor @@ -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 diff --git a/contrib/space-invaders/space-invaders.factor b/contrib/space-invaders/space-invaders.factor index 69dc4bb9f1..c93a50f595 100644 --- a/contrib/space-invaders/space-invaders.factor +++ b/contrib/space-invaders/space-invaders.factor @@ -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 [ diff --git a/contrib/sqlite/sqlite.factor b/contrib/sqlite/sqlite.factor index 3ed6f83997..b2c65e2b8b 100644 --- a/contrib/sqlite/sqlite.factor +++ b/contrib/sqlite/sqlite.factor @@ -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) ;