steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

rename ifte to if

cvs
Slava Pestov 2005-09-24 19:21:17 +00:00
parent ebf9a3fe7f
commit c4cec1321c
142 changed files with 630 additions and 631 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CHANGES.html
View File

@ -8,6 +8,8 @@
<ul>
<li>The <code>ifte</code> combinator has been renamed to <code>if</code>!</li>
<li>Compiler:
<ul>

56
doc/handbook.tex
View File

@ -937,10 +937,10 @@ It is very important to balance usages of \texttt{>r} and \texttt{r>} within a s
\end{verbatim}
Basically, the rule is you must leave the call stack in the same state as you found it, so that when the current quotation finishes executing, the interpreter can return to the caller.
One exception is that when \texttt{ifte} occurs as the last word in a definition, values may be pushed on the call stack before the condition value is computed, as long as both branches of the \texttt{ifte} pop the values off the call stack before returning.
One exception is that when \texttt{if} occurs as the last word in a definition, values may be pushed on the call stack before the condition value is computed, as long as both branches of the \texttt{if} pop the values off the call stack before returning.
\begin{verbatim}
: foo ( m ? n -- m+n/n )
>r [ r> + ] [ drop r> ] ifte ; ! Okay
>r [ r> + ] [ drop r> ] if ; ! Okay
\end{verbatim}
\subsection{Quotation variants}
@ -986,10 +986,10 @@ Call a quotation with three values on the stack, restoring the values when the q
\section{Conditionals}
The simplest style of a conditional form is the \texttt{ifte} word.
The simplest style of a conditional form is the \texttt{if} word.
\wordtable{
\vocabulary{kernel}
\ordinaryword{ifte}{ifte ( cond true false -- )}
\ordinaryword{if}{if ( cond true false -- )}
}
The \texttt{cond} is a generalized boolean. If it is \texttt{f}, the \texttt{false} quotation is called, and if \texttt{cond} is any other value, the \texttt{true} quotation is called. The condition flag is removed from the stack before either quotation executes.
@ -999,52 +999,52 @@ Note that in general, both branches should have the same stack effect. Not only
\ordinaryword{when}{when ( cond true -- | true:~-- )}
\ordinaryword{unless}{unless ( cond false -- | false:~-- )}
}
This pair are minor variations on \texttt{ifte} where only one branch is specified. The other is implicitly \texttt{[ ]}. They are implemented in the trivial way:
This pair are minor variations on \texttt{if} where only one branch is specified. The other is implicitly \texttt{[ ]}. They are implemented in the trivial way:
\begin{verbatim}
: when [ ] ifte ; inline
: unless [ ] swap ifte ; inline
: when [ ] if ; inline
: unless [ ] swap if ; inline
\end{verbatim}
The \texttt{ifte} word removes the condition flag from the stack before calling either quotation. Sometimes this is not desirable, if the condition flag is serving a dual purpose as a value to be consumed by the \texttt{true} quotation. The \texttt{ifte*} word exists for this purpose.
The \texttt{if} word removes the condition flag from the stack before calling either quotation. Sometimes this is not desirable, if the condition flag is serving a dual purpose as a value to be consumed by the \texttt{true} quotation. The \texttt{if*} word exists for this purpose.
\wordtable{
\vocabulary{kernel}
\ordinaryword{ifte*}{ifte*~( cond true false -- )}
\ordinaryword{if*}{if*~( cond true false -- )}
\texttt{true:~cond --}\\
\texttt{false:~--}\\
}
If the condition is true, it is retained on the stack before the \texttt{true} quotation is called. Otherwise, the condition is removed from the stack and the \texttt{false} quotation is called. The following two lines are equivalent:
\begin{verbatim}
X [ Y ] [ Z ] ifte*
X dup [ Y ] [ drop Z ] ifte
X [ Y ] [ Z ] if*
X dup [ Y ] [ drop Z ] if
\end{verbatim}
\wordtable{
\vocabulary{kernel}
\ordinaryword{when*}{when*~( cond true -- | true:~cond -- )}
\ordinaryword{unless*}{unless*~( cond false -- | false:~-- )}
}
These are variations of \texttt{ifte*} where one of the quotations is \texttt{[ ]}.
These are variations of \texttt{if*} where one of the quotations is \texttt{[ ]}.
The following two lines are equivalent:
\begin{verbatim}
X [ Y ] when*
X dup [ Y ] [ drop ] ifte
X dup [ Y ] [ drop ] if
\end{verbatim}
The following two lines are equivalent:
\begin{verbatim}
X [ Y ] unless*
X dup [ ] [ drop Y ] ifte
X dup [ ] [ drop Y ] if
\end{verbatim}
There is one final conditional form that is used to implement the ``default value'' idiom.
\wordtable{
\vocabulary{kernel}
\ordinaryword{?ifte}{?ifte ( default cond true false -- )}
\ordinaryword{?if}{?if ( default cond true false -- )}
\texttt{true:~cond --}\\
\texttt{false:~default --}\\
}
If the condition is \texttt{f}, the \texttt{false} quotation is called with the \texttt{default} value on the stack. Otherwise, the \texttt{true} quotation is called with the condition on the stack. The following two lines are equivalent:
\begin{verbatim}
D X [ Y ] [ Z ] ?ifte
D X dup [ nip Y ] [ drop Z ] ifte
D X [ Y ] [ Z ] ?if
D X dup [ nip Y ] [ drop Z ] if
\end{verbatim}
\subsection{Boolean logic}
@ -1057,7 +1057,7 @@ The \texttt{?}~word chooses between two values, rather than two quotations.
It is implemented in the obvious way.
\begin{verbatim}
: ? ( cond t f -- t/f )
rot [ drop ] [ nip ] ifte ; inline
rot [ drop ] [ nip ] if ; inline
\end{verbatim}
Several words use \texttt{?}~to implement typical boolean algebraic operations.
\wordtable{
@ -3559,7 +3559,7 @@ Computes the bitwise complement of the input; that is, each bit in the input num
\vocabulary{math}
\ordinaryword{shift}{shift ( x n -{}- y )}
}
Computes a new integer consisting of the bits of the first integer, shifted to the left by $n$ positions. If $n$ is negative, the bits are shifted to the right instead, and bits that ``fall off'' are discarded.
Computes a new integer consisting of the bits of the first integer, shifd to the left by $n$ positions. If $n$ is negative, the bits are shifd to the right instead, and bits that ``fall off'' are discarded.
\begin{alltt}
BIN: 101 5 shift .b
\textbf{10100000}
@ -4628,7 +4628,7 @@ M: tex-stream stream-format ( string attrs stream -- )
"\textbf{" write write "}" write
] [
write
] ifte
] if
] with-wrapper ;
\end{verbatim}
@ -4923,7 +4923,7 @@ M: wrapper prettyprint*
\ \ unparse. bl wrapped unparse.
] [
\ W[ unparse. bl wrapped prettyprint* \ ]W unparse.
] ifte ;
] if ;
\end{verbatim}
The somewhat more verbose \verb|W[ ... ]W| syntax is only part of the language for completeness, to handle the corner case where a wrapper wrapping another wrapper is printed out and read back in by the parser.
@ -6510,12 +6510,12 @@ Simpler than a stack effect is the concept of a stack height difference. This is
The following two examples exhibit balanced conditionals:
\begin{verbatim}
[ 1 ] [ dup ] ifte
[ 1 ] [ dup ] if
dup cons? [ unit ] when cons
\end{verbatim}
The following example is not balanced and raises an error when we attempt to infer its stack effect:
\begin{alltt}
[ [ dup ] [ drop ] ifte ] infer .
[ [ dup ] [ drop ] if ] infer .
\textbf{! Inference error: Unbalanced branches
! Recursive state:
:s :r :n :c show stacks at time of error.
@ -6529,7 +6529,7 @@ Recursive words all have the same general form; there is a conditional, and one
Consider the following implementation of a word that measures the length of a list:
\begin{verbatim}
: length ( list -- n )
[ cdr length 1 + ] [ 0 ] ifte* ;
[ cdr length 1 + ] [ 0 ] if* ;
\end{verbatim}
The stack effect can be inferred without difficulty:
\begin{alltt}
@ -6542,7 +6542,7 @@ On the other hand if the top of the stack is something else, the inductive case
If both branches contain a recursive call, the stack effect inferencer gives up.
\begin{alltt}
: fie [ fie ] [ fie ] ifte ;
: fie [ fie ] [ fie ] if ;
[ fie ] infer .
\textbf{! Inference error: fie does not have a base case
! Recursive state:
@ -6657,7 +6657,7 @@ The \verb|value| tuple has one slot, \verb|value-recursion|. This is a list of n
\begin{description}
\item[\texttt{\#ifte}] A conditional expression.
\item[\texttt{\#if}] A conditional expression.
\begin{description}
\item[\texttt{node-in-d}]A singleton list holding the condition being tested.\\
@ -6671,13 +6671,13 @@ The \verb|value| tuple has one slot, \verb|value-recursion|. This is a list of n
\item[\texttt{node-children}]A list of nodes, in consecutive jump table order.
\end{description}
\item[\texttt{\#values}] Found at the end of each branch in an \verb|#ifte| or \verb|#dispatch| node.
\item[\texttt{\#values}] Found at the end of each branch in an \verb|#if| or \verb|#dispatch| node.
\begin{description}
\item[\texttt{node-out-d}]A list of values present on the data stack at the end of the branch.\\
\end{description}
\item[\texttt{\#meet}] Must be the successor if an \verb|#ifte| or \verb|#dispatch| node.
\item[\texttt{\#meet}] Must be the successor if an \verb|#if| or \verb|#dispatch| node.
\begin{description}
\item[\texttt{node-in-d}]A list of \verb|meet| values unified from the \verb|#values| node at the end of each branch.\\

4
examples/dejong.factor
View File

@ -48,10 +48,10 @@ SYMBOL: d
drop
] [
event-loop
] ifte
] if
] [
drop
] ifte ; compiled
] if ; compiled
: dejong ( -- )
! Fiddle with these four values!

4
examples/factorbot.factor
View File

@ -46,7 +46,7 @@ M: privmsg handle-irc ( line -- )
parse-privmsg
" " split1 swap
[ "factorbot-commands" ] search dup
[ execute ] [ 2drop ] ifte ;
[ execute ] [ 2drop ] if ;
M: ping handle-irc ( line -- )
"PING " ?head drop "PONG " swap append irc-print ;
@ -97,7 +97,7 @@ IN: factorbot-commands
nip [
dup word-string " -- " rot word-url append3 respond
] each
] ifte ;
] if ;
: quit ( text -- )
drop speaker get "slava" = [ disconnect ] when ;

8
examples/mandel.factor
View File

@ -94,7 +94,7 @@ USE: test
: iter ( c z nb-iter -- x )
over absq 4.0 >= over 0 = or
[ 2nip ] [ 1- >r sq dupd + r> iter ] ifte ;
[ 2nip ] [ 1- >r sq dupd + r> iter ] if ;
: max-color 360 ;
@ -123,7 +123,7 @@ SYMBOL: center
drop 0
] [
cols get [ length mod ] keep nth
] ifte
] if
] with-pixels ; compiled
: event-loop ( event -- )
@ -132,10 +132,10 @@ SYMBOL: center
drop
] [
event-loop
] ifte
] if
] [
drop
] ifte ; compiled
] if ; compiled
: mandel ( -- )
1280 1024 0 SDL_HWSURFACE [

6
examples/numbers-game.factor
View File

@ -11,15 +11,15 @@ USING: kernel math parser random io ;
: correct "Correct - you win!" 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 ;
2dup = [ 2drop correct f ] [ inexact-guess t ] if ;
: number-to-guess ( -- n ) 0 100 random-int ;
: numbers-game-loop ( actual -- )
dup guess-prompt read-number judge-guess
[ numbers-game-loop ] [ drop ] ifte ;
[ numbers-game-loop ] [ drop ] if ;
: numbers-game number-to-guess numbers-game-loop ;

4
examples/plot3d.factor
View File

@ -151,10 +151,10 @@ SYMBOL: theta
drop
] [
event-loop
] ifte
] if
] [
event-loop
] ifte ;
] if ;
: plot3d ( -- )
1024 768 16 flags [

12
examples/raytracer.factor
View File

@ -39,11 +39,11 @@ TUPLE: sphere center radius ;
: -+ ( x y -- x-y x+y ) [ - ] 2keep + ;
: sphere-b/d ( b d -- t )
-+ dup 0.0 < [ 2drop inf ] [ >r [ 0.0 > ] keep r> ? ] ifte ;
-+ dup 0.0 < [ 2drop inf ] [ >r [ 0.0 > ] keep r> ? ] if ;
: ray-sphere ( sphere ray -- t )
2dup sphere-v tuck sphere-b [ sphere-disc ] keep
over 0.0 < [ 2drop inf ] [ swap sqrt sphere-b/d ] ifte ;
over 0.0 < [ 2drop inf ] [ swap sqrt sphere-b/d ] if ;
: sphere-n ( ray sphere l -- n )
pick ray-dir n*v swap sphere-center v- swap ray-orig v+ ;
@ -51,7 +51,7 @@ TUPLE: sphere center radius ;
: if-ray-sphere ( hit ray sphere quot -- hit )
#! quot: hit ray sphere l -- hit
>r pick hit-lambda >r 2dup swap ray-sphere dup r> >=
[ 3drop ] r> ifte ; inline
[ 3drop ] r> if ; inline
M: sphere intersect-scene ( hit ray sphere -- hit )
[ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
@ -91,8 +91,8 @@ M: group intersect-scene ( hit ray group -- hit )
3drop 0.0
] [
dup ray-g >r sray-intersect hit-lambda inf =
[ r> neg ] [ r> drop 0.0 ] ifte
] ifte ;
[ r> neg ] [ r> drop 0.0 ] if
] if ;
: create-center ( c r d -- c2 ) >r 3.0 12.0 sqrt / * r> n*v v+ ;
@ -118,7 +118,7 @@ DEFER: create ( level c r -- scene )
] make-group ;
: create ( level c r -- scene )
pick 1 = [ <sphere> nip ] [ create-group ] ifte ;
pick 1 = [ <sphere> nip ] [ create-group ] if ;
: ss-point ( dx dy -- point )
[ oversampling /f ] 2apply 0.0 3array ;

2
library/alien/aliens.factor
View File

@ -13,7 +13,7 @@ M: alien = ( obj obj -- ? )
alien-address swap alien-address =
] [
2drop f
] ifte ;
] if ;
: library ( name -- object )
dup [ "libraries" get hash ] when ;

2
library/alien/c-types.factor
View File

@ -20,7 +20,7 @@ SYMBOL: c-types
: c-type ( name -- type )
dup c-types get hash [ ] [
"No such C type: " swap append throw f
] ?ifte ;
] ?if ;
: c-size ( name -- size )
c-type [ "width" get ] bind ;

10
library/alien/compiler.factor
View File

@ -86,10 +86,10 @@ C: alien-node make-node ;
int-regs [ swap float-regs-size 4 / + ] change
] [
drop
] ifte
] if
] [
drop
] ifte ;
] if ;
: load-parameter ( n parameter -- node )
c-type "reg-class" swap hash
@ -116,7 +116,7 @@ C: alien-node make-node ;
drop
] [
c-type [ "boxer" get "reg-class" get ] bind %box ,
] ifte ;
] if ;
M: alien-node linearize* ( node -- )
dup parameters linearize-parameters
@ -127,7 +127,7 @@ M: alien-node linearize* ( node -- )
: unpair ( seq -- odds evens )
2 swap group flip dup empty?
[ drop { } { } ] [ first2 ] ifte ;
[ drop { } { } ] [ first2 ] if ;
: parse-arglist ( lst -- types stack effect )
unpair [
@ -164,4 +164,4 @@ M: compound (uncrossref)
] [
dup { "infer-effect" "base-case" "no-effect" "terminates" }
reset-props update-xt
] ifte ;
] if ;

4
library/bootstrap/boot-stage2.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
USING: alien assembler command-line compiler compiler-backend
USING: alien assembler compiler compiler-backend
errors generic hashtables io io-internals kernel
kernel-internals lists math memory namespaces optimizer parser
sequences sequences-internals words ;
@ -12,7 +12,7 @@ sequences sequences-internals words ;
] each
] [
drop
] ifte ;
] if ;
"Loading compiler backend..." print

8
library/bootstrap/image.factor
View File

@ -37,7 +37,7 @@ SYMBOL: 64-bits
emit
] [
d>w/w big-endian get [ swap ] unless emit emit
] ifte ;
] if ;
: emit-seq ( seq -- ) image get swap nappend ;
@ -175,13 +175,13 @@ M: f ' ( obj -- ptr )
: transfer-word ( word -- word )
#! This is a hack. See doc/bootstrap.txt.
dup dup word-name swap word-vocabulary lookup
[ ] [ dup "Missing DEFER: " word-error ] ?ifte ;
[ ] [ dup "Missing DEFER: " word-error ] ?if ;
: pooled-object ( object -- ptr ) objects get hash ;
: fixup-word ( word -- offset )
transfer-word dup pooled-object dup
[ nip ] [ "Not in image: " word-error ] ifte ;
[ nip ] [ "Not in image: " word-error ] if ;
: fixup-words ( -- )
image get [ dup word? [ fixup-word ] when ] inject ;
@ -297,7 +297,7 @@ M: hashtable ' ( hashtable -- pointer )
[ swap >be write ] each-with
] [
[ swap >le write ] each-with
] ifte ;
] if ;
: write-image ( image file -- )
"Writing image to " write dup write "..." print

2
library/bootstrap/init.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel-internals
USING: assembler command-line errors io io-internals kernel
USING: assembler errors io io-internals kernel
namespaces parser threads words ;
: boot ( -- )

2
library/bootstrap/primitives.factor
View File

@ -28,7 +28,7 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
{
{ "execute" "words" }
{ "call" "kernel" }
{ "ifte" "kernel" }
{ "if" "kernel" }
{ "dispatch" "kernel-internals" }
{ "cons" "lists" }
{ "<vector>" "vectors" }

29
library/cli.factor
View File

@ -1,26 +1,23 @@
! Copyright (C) 2003, 2004 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: command-line
USING: errors io kernel kernel-internals lists namespaces parser
sequences strings ;
! This file is run as the last stage of boot.factor; it relies
! on all other words already being defined.
IN: kernel
USING: errors hashtables io kernel-internals lists namespaces
parser sequences strings ;
: ?run-file ( file -- )
dup exists? [ [ dup run-file ] try drop ] [ drop ] ifte ;
dup exists? [ [ dup run-file ] try ] when drop ;
: run-user-init ( -- )
#! Run user init file if it exists
"user-init" get
[ "~" get "/.factor-rc" append ?run-file ] when ;
: set-path ( value list -- )
unswons over [ nest [ set-path ] bind ] [ nip set ] ifte ;
: set-path ( value seq -- )
unswons over [ nest [ set-path ] bind ] [ nip set ] if ;
: cli-var-param ( name value -- ) swap ":" split set-path ;
: cli-bool-param ( name -- ) "no-" ?head not swap set ;
: cli-bool-param ( name -- ) "no-" ?head not cli-var-param ;
: cli-param ( param -- )
#! Handle a command-line argument starting with '-' by
@ -29,7 +26,7 @@ sequences strings ;
#!
#! Arguments containing = are handled differently; they
#! set the object path.
"=" split1 [ cli-var-param ] [ cli-bool-param ] ifte* ;
"=" split1 [ cli-var-param ] [ cli-bool-param ] if* ;
: cli-arg ( argument -- argument )
#! Handle a command-line argument. If the argument was
@ -40,12 +37,6 @@ sequences strings ;
dup [ "+" ?head [ drop f ] when ] when
] unless ;
: parse-switches ( args -- args )
[ cli-arg ] map ;
: run-files ( args -- )
[ [ run-file ] when* ] each ;
: cli-args ( -- args ) 10 getenv ;
: default-cli-args
@ -57,6 +48,4 @@ sequences strings ;
os "win32" = "ui" "tty" ? "shell" set ;
: parse-command-line ( -- )
#! Parse command line arguments.
#! The first CLI arg is the image name.
cli-args unswons "image" set parse-switches run-files ;
cli-args [ cli-arg ] subset [ run-file ] each ;

2
library/collections/arrays.factor
View File

@ -12,7 +12,7 @@ USING: kernel math math-internals sequences sequences-internals ;
] all? 2nip
] [
2drop f
] ifte ; flushable
] if ; flushable
IN: arrays

2
library/collections/assoc.factor
View File

@ -29,5 +29,5 @@ IN: lists USING: kernel sequences ;
#! corresponding quotation, the value is popped off the
#! stack.
swap [
unswons rot assoc* dup [ cdr call ] [ 2drop ] ifte
unswons rot assoc* dup [ cdr call ] [ 2drop ] if
] each-with ;

12
library/collections/hashtables.factor
View File

@ -61,7 +61,7 @@ IN: hashtables
-rot 2dup (hashcode) over [
( quot key hash assoc -- )
swapd 2dup
assoc* [ rot hash-size- ] [ rot drop ] ifte
assoc* [ rot hash-size- ] [ rot drop ] if
rot call
] change-bucket ; inline
@ -86,7 +86,7 @@ IN: hashtables
dup hash-size new-size swap set-bucket-count
] [
drop
] ifte ;
] if ;
: set-hash ( value key table -- )
#! Store the value in the hashtable. Either replaces an
@ -130,7 +130,7 @@ IN: hashtables
cdr r> =
] [
r> 2drop f
] ifte
] if
] hash-all-with? ; flushable
: hash-filter-step ( quot assoc -- assoc n )
@ -179,17 +179,17 @@ M: hashtable hashcode ( hash -- n )
>r 3drop r>
] [
pick rot >r >r call dup r> r> set-hash
] ifte* ; inline
] if* ; inline
: map>hash ( seq quot -- hash | quot: elt -- value )
over >r map r> dup length <hashtable> -rot
[ pick set-hash ] 2each ; inline
: ?hash ( key hash/f -- value/f )
dup [ hash ] [ 2drop f ] ifte ; flushable
dup [ hash ] [ 2drop f ] if ; flushable
: ?hash* ( key hash/f -- value/f )
dup [ hash* ] [ 2drop f ] ifte ; flushable
dup [ hash* ] [ 2drop f ] if ; flushable
: ?set-hash ( value key hash/f -- hash )
[ 1 <hashtable> ] unless* [ set-hash ] keep ;

8
library/collections/lists.factor
View File

@ -31,10 +31,10 @@ M: cons map ( cons quot -- cons )
r> car r> drop r> swap
] [
r> cdr r> r> 1+ (list-find)
] ifte
] if
] [
3drop -1 f
] ifte ; inline
] if ; inline
M: general-list find ( list quot -- i elt )
0 (list-find) ;
@ -50,14 +50,14 @@ M: general-list head ( n list -- list )
unswons >r >r 1- r> head r> swons
] [
2drop f
] ifte ;
] if ;
M: general-list tail ( n list -- tail )
#! Return the rest of the list, from the nth index onward.
swap [ cdr ] times ;
M: general-list nth ( n list -- element )
over 0 number= [ nip car ] [ >r 1- r> cdr nth ] ifte ;
over 0 number= [ nip car ] [ >r 1- r> cdr nth ] if ;
M: cons = ( obj cons -- ? )
@{

14
library/collections/namespaces.factor
View File

@ -49,10 +49,10 @@ strings vectors words ;
nip cdr ( found )
] [
cdr (get) ( keep looking )
] ?ifte
] ?if
] [
2drop f
] ifte ; flushable
] if ; flushable
: get ( variable -- value )
#! Push the value of a variable by searching the namestack
@ -64,7 +64,7 @@ strings vectors words ;
: nest ( variable -- hash )
#! If the variable is set in the current namespace, return
#! its value, otherwise set its value to a new namespace.
dup namespace hash [ ] [ >r {{ }} clone dup r> set ] ?ifte ;
dup namespace hash [ ] [ >r {{ }} clone dup r> set ] ?if ;
: change ( var quot -- )
#! Execute the quotation with the variable value on the
@ -102,7 +102,7 @@ SYMBOL: building
#! Add to the sequence being built with make-seq.
building get push ;
: ?, ( obj ? -- ) [ , ] [ drop ] ifte ;
: ?, ( obj ? -- ) [ , ] [ drop ] if ;
: % ( seq -- )
#! Append to the sequence being built with make-seq.
@ -121,11 +121,11 @@ SYMBOL: hash-buffer
: (closure) ( key hash -- )
tuck hash dup [
hash-keys [
dup dup closure, [ 2drop ] [ swap (closure) ] ifte
dup dup closure, [ 2drop ] [ swap (closure) ] if
] each-with
] [
2drop
] ifte ;
] if ;
: closure ( key hash -- list )
[
@ -137,4 +137,4 @@ SYMBOL: hash-buffer
IN: lists
: alist>quot ( default alist -- quot )
[ unswons [ % , , \ ifte , ] [ ] make ] each ;
[ unswons [ % , , \ if , ] [ ] make ] each ;

4
library/collections/queues.factor
View File

@ -20,5 +20,5 @@ C: queue ( -- queue ) ;
f rot set-queue-in
] [
"Empty queue" throw
] ifte*
] ifte* ;
] if*
] if* ;

6
library/collections/sequence-combinators.factor
View File

@ -91,8 +91,8 @@ M: object map ( seq quot -- seq )
r> dup r> nth-unsafe r> drop
] [
r> 1+ r> r> find*
] ifte
] ifte ; inline
] if
] if ; inline
: find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
-rot [ with rot ] find* 2swap 2drop ; inline
@ -122,7 +122,7 @@ M: object find ( seq quot -- i elt )
r> r> r> [ push ] keep swap
] [
r> r> drop r> swap
] ifte
] if
] each drop
] keep like ; inline

10
library/collections/sequence-eq.factor
View File

@ -15,14 +15,14 @@ UNION: sequence array string sbuf vector ;
dup length [ >r 2dup r> 2nth-unsafe = ] all? 2nip
] [
2drop f
] ifte ; flushable
] if ; flushable
M: sequence = ( obj seq -- ? )
2dup eq? [
2drop t
] [
over type over type eq? [ sequence= ] [ 2drop f ] ifte
] ifte ;
over type over type eq? [ sequence= ] [ 2drop f ] if
] if ;
M: sequence hashcode ( seq -- n )
#! Poor
@ -31,7 +31,7 @@ M: sequence hashcode ( seq -- n )
M: string = ( obj str -- ? )
over string? [
over hashcode over hashcode number=
[ sequence= ] [ 2drop f ] ifte
[ sequence= ] [ 2drop f ] if
] [
2drop f
] ifte ;
] if ;

14
library/collections/sequence-sort.factor
View File

@ -53,11 +53,11 @@ DEFER: (nsort)
[ dup sorter-seq swap s*/e (nsort) ] 2keep
] [
2drop
] ifte 2drop ; inline
] if 2drop ; inline
: partition ( -1/1 seq -- seq )
dup midpoint@ swap rot 1 <
[ head-slice ] [ tail-slice ] ifte ; inline
[ head-slice ] [ tail-slice ] if ; inline
: (binsearch) ( elt quot seq -- i )
dup length 1 <= [
@ -67,8 +67,8 @@ DEFER: (nsort)
r> r> 3drop r> dup slice-from swap slice-to + 2 /i
] [
r> swap r> swap r> partition (binsearch)
] ifte
] ifte ; inline
] if
] if ; inline
: flatten-slice ( seq -- slice )
#! Binsearch returns an index relative to the sequence
@ -81,7 +81,7 @@ IN: sequences
: nsort ( seq quot -- | quot: elt elt -- -1/0/1 )
swap dup length 1 <=
[ 2drop ] [ 0 over length 1- (nsort) ] ifte ; inline
[ 2drop ] [ 0 over length 1- (nsort) ] if ; inline
: sort ( seq quot -- seq | quot: elt elt -- -1/0/1 )
swap [ swap nsort ] immutable ; inline
@ -92,9 +92,9 @@ IN: sequences
: binsearch ( elt seq quot -- i | quot: elt elt -- -1/0/1 )
swap dup empty?
[ 3drop -1 ] [ flatten-slice (binsearch) ] ifte ;
[ 3drop -1 ] [ flatten-slice (binsearch) ] if ;
inline
: binsearch* ( elt seq quot -- elt | quot: elt elt -- -1/0/1 )
over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] ifte ;
over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] if ;
inline

16
library/collections/sequences-epilogue.factor
View File

@ -12,8 +12,8 @@ sequences strings vectors words ;
2drop 1+ r> (lexi)
] [
r> drop - >r 3drop r>
] ifte
] ifte ; flushable
] if
] if ; flushable
IN: sequences
@ -26,7 +26,7 @@ M: object empty? ( seq -- ? ) length 0 = ;
3drop [ ]
] [
2dup nth >r >r 1+ r> (>list) r> swons
] ifte ;
] if ;
M: object >list ( seq -- list ) dup length 0 rot (>list) ;
@ -38,7 +38,7 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
: (subst) ( newseq oldseq elt -- new/elt )
[ swap index ] keep
over -1 > [ drop swap nth ] [ 2nip ] ifte ;
over -1 > [ drop swap nth ] [ 2nip ] if ;
: subst ( newseq oldseq seq -- )
#! Mutates seq. If an element of seq occurs in oldseq,
@ -47,7 +47,7 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
: move ( to from seq -- )
pick pick number=
[ 3drop ] [ [ nth swap ] keep set-nth ] ifte ; inline
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
: (delete) ( elt store scan seq -- )
2dup length < [
@ -117,7 +117,7 @@ M: object peek ( sequence -- element )
dup length <vector> swap
[ over push 2dup push ] each nip dup pop*
concat
] ifte ; flushable
] if ; flushable
M: object reverse-slice ( seq -- seq ) <reversed> ;
@ -153,10 +153,10 @@ IN: kernel
: cond ( conditions -- )
#! Conditions is a sequence of quotation pairs.
#! { { [ X ] [ Y ] } { [ Z ] [ T ] } }
#! => X [ Y ] [ Z [ T ] [ ] ifte ] ifte
#! => X [ Y ] [ Z [ T ] [ ] if ] if
#! The last condition should be a catch-all 't'.
[ first call ] find nip dup
[ second call ] [ no-cond ] ifte ;
[ second call ] [ no-cond ] if ;
: with-datastack ( stack word -- stack )
datastack >r >r set-datastack r> execute

2
library/collections/sequences.factor
View File

@ -52,7 +52,7 @@ TUPLE: bounds-error index seq ;
: growable-check ( n seq -- fx seq )
>r >fixnum dup 0 fixnum<
[ r> 2dup bounds-error ] [ r> ] ifte ; inline
[ r> 2dup bounds-error ] [ r> ] if ; inline
: bounds-check ( n seq -- fx seq )
growable-check 2dup length fixnum>=

18
library/collections/slicing.factor
View File

@ -29,27 +29,27 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
2drop f
] [
dup length rot head-slice sequence=
] ifte ; flushable
] if ; flushable
: ?head ( seq begin -- str ? )
2dup head? [ length swap tail t ] [ drop f ] ifte ; flushable
2dup head? [ length swap tail t ] [ drop f ] if ; flushable
: tail? ( seq end -- ? )
2dup [ length ] 2apply < [
2drop f
] [
dup length rot tail-slice* sequence=
] ifte ; flushable
] if ; flushable
: ?tail ( seq end -- seq ? )
2dup tail? [ length swap head* t ] [ drop f ] ifte ; flushable
2dup tail? [ length swap head* t ] [ drop f ] if ; flushable
: (group) ( n seq -- )
2dup length >= [
dup like , drop
] [
2dup head , dupd tail-slice (group)
] ifte ;
] if ;
: group ( n seq -- seq ) [ (group) ] { } make ; flushable
@ -64,8 +64,8 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
r> 2drop r>
] [
r> r> 1+ start*
] ifte
] ifte ; flushable
] if
] if ; flushable
: start ( subseq seq -- n )
#! The index of a subsequence in a sequence.
@ -79,14 +79,14 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
2drop dup like f
] [
[ swap length + over tail-slice ] keep rot head swap
] ifte ; flushable
] if ; flushable
: split1 ( seq subseq -- before after )
#! After is of the same type as seq.
(split1) dup like ; flushable
: (split) ( seq subseq -- )
tuck (split1) >r , r> dup [ swap (split) ] [ 2drop ] ifte ;
tuck (split1) >r , r> dup [ swap (split) ] [ 2drop ] if ;
: split ( seq subseq -- seq ) [ (split) ] [ ] make ; flushable

2
library/collections/strings-epilogue.factor
View File

@ -11,7 +11,7 @@ sequences strings ;
<repeated> >string ; inline
: padding ( string count char -- string )
>r swap length - dup 0 <= [ r> 2drop "" ] [ r> fill ] ifte ;
>r swap length - dup 0 <= [ r> 2drop "" ] [ r> fill ] if ;
flushable
: pad-left ( string count char -- string )

2
library/collections/vectors.factor
View File

@ -27,5 +27,5 @@ M: general-list like drop >list ;
M: vector like
drop dup vector? [
dup array? [ array>vector ] [ >vector ] ifte
dup array? [ array>vector ] [ >vector ] if
] unless ;

4
library/compiler/basic-blocks.factor
View File

@ -9,8 +9,8 @@ USING: arrays hashtables kernel lists math namespaces sequences ;
>r 1+ r> (split-blocks)
] [
(cut) >r , 1 r> (cut) >r , 0 r> (split-blocks)
] ifte
] ifte ;
] if
] if ;
: split-blocks ( linear -- blocks )
[ 0 swap (split-blocks) ] { } make ;

2
library/compiler/compiler.factor
View File

@ -38,7 +38,7 @@ words ;
gensym [ swap define-compound ] keep dup compile execute
] [
call
] ifte ;
] if ;
\ dataflow profile
\ linearize profile

34
library/compiler/intrinsics.factor
View File

@ -15,19 +15,19 @@ namespaces sequences words ;
#! If the tag is known, output it, otherwise f.
node-classes ?hash dup [
types [ type-tag ] map dup all-equal?
[ first ] [ drop f ] ifte
[ first ] [ drop f ] if
] [
drop f
] ifte ;
] if ;
: slot@ ( node -- n/f )
#! Compute slot offset.
dup node-in-d reverse dup first dup literal? [
literal-value cell * swap second
rot value-tag dup [ - ] [ 2drop f ] ifte
rot value-tag dup [ - ] [ 2drop f ] if
] [
3drop f
] ifte ;
] if ;
\ slot [
dup slot@ [
@ -40,7 +40,7 @@ namespaces sequences words ;
-1 %inc-d ,
0 %untag ,
1 0 %slot ,
] ifte out-1
] if out-1
] "intrinsic" set-word-prop
\ set-slot [
@ -55,7 +55,7 @@ namespaces sequences words ;
-3 %inc-d ,
1 %untag ,
0 1 2 %set-slot ,
] ifte
] if
1 %write-barrier ,
] "intrinsic" set-word-prop
@ -109,7 +109,7 @@ namespaces sequences words ;
>r binary-imm dup r> execute , out-1 ; inline
: literal-immediate? ( value -- ? )
dup literal? [ literal-value immediate? ] [ drop f ] ifte ;
dup literal? [ literal-value immediate? ] [ drop f ] if ;
: binary-op-imm? ( node -- ? )
fixnum-imm? >r node-peek literal-immediate? r> and ;
@ -117,7 +117,7 @@ namespaces sequences words ;
: binary-op ( node op -- )
#! out is a vreg where the vop stores the result.
over binary-op-imm?
[ binary-op-imm ] [ binary-op-reg ] ifte ;
[ binary-op-imm ] [ binary-op-reg ] if ;
{
{ fixnum+ %fixnum+ }
@ -138,7 +138,7 @@ namespaces sequences words ;
: binary-jump ( node label op -- )
pick binary-op-imm?
[ binary-jump-imm ] [ binary-jump-reg ] ifte ;
[ binary-jump-imm ] [ binary-jump-reg ] if ;
{
{ fixnum<= %jump-fixnum<= }
{ fixnum< %jump-fixnum< }
@ -147,7 +147,7 @@ namespaces sequences words ;
{ eq? %jump-eq? }
} [
first2 [ literalize , \ binary-jump , ] [ ] make
"ifte-intrinsic" set-word-prop
"if-intrinsic" set-word-prop
] each
\ fixnum/i [
@ -198,10 +198,10 @@ namespaces sequences words ;
nip fast-fixnum*
] [
drop slow-fixnum*
] ifte
] if
] [
drop slow-fixnum*
] ifte
] if
] "intrinsic" set-word-prop
: slow-shift ( -- ) \ fixnum-shift %call , ;
@ -215,7 +215,7 @@ namespaces sequences words ;
] [
neg 0 <vreg> 0 <vreg> %fixnum>> ,
out-1
] ifte ;
] if ;
: positive-shift ( n -- )
dup cell 8 * tag-bits - <= [
@ -225,7 +225,7 @@ namespaces sequences words ;
out-1
] [
drop slow-shift
] ifte ;
] if ;
: fast-shift ( n -- )
dup 0 = [
@ -236,13 +236,13 @@ namespaces sequences words ;
negative-shift
] [
positive-shift
] ifte
] ifte ;
] if
] if ;
\ fixnum-shift [
node-peek dup literal? [
literal-value fast-shift
] [
drop slow-shift
] ifte
] if
] "intrinsic" set-word-prop

22
library/compiler/linearizer.factor
View File

@ -35,37 +35,37 @@ M: #label linearize* ( node -- )
node-param r> drop r> execute ,
] [
dup node-param r> execute , r> drop linearize-next
] ifte ; inline
] if ; inline
: intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
: ifte-intrinsic ( #call -- quot )
dup node-successor #ifte?
[ node-param "ifte-intrinsic" word-prop ] [ drop f ] ifte ;
: if-intrinsic ( #call -- quot )
dup node-successor #if?
[ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
: linearize-ifte ( node label -- )
: linearize-if ( node label -- )
#! Assume the quotation emits a VOP that jumps to the label
#! if some condition holds; we linearize the false branch,
#! then the label, then the true branch.
>r node-children first2 linearize* r> %label , linearize* ;
M: #call linearize* ( node -- )
dup ifte-intrinsic [
dup if-intrinsic [
>r <label> 2dup r> call
>r node-successor r> linearize-ifte
>r node-successor r> linearize-if
] [
dup intrinsic [
dupd call linearize-next
] [
\ %call \ %jump ?tail-call
] ifte*
] ifte* ;
] if*
] if* ;
M: #call-label linearize* ( node -- )
\ %call-label \ %jump-label ?tail-call ;
M: #ifte linearize* ( node -- )
<label> dup in-1 -1 %inc-d , 0 %jump-t , linearize-ifte ;
M: #if linearize* ( node -- )
<label> dup in-1 -1 %inc-d , 0 %jump-t , linearize-if ;
: dispatch-head ( vtable -- label/code )
#! Output the jump table insn and return a list of

8
library/compiler/ppc/alien.factor
View File

@ -11,7 +11,7 @@ M: %alien-invoke generate-node ( vop -- )
M: %parameters generate-node ( vop -- )
0 vop-in dup 0 =
[ drop ] [ stack-reserve 1 1 rot SUBI ] ifte ;
[ drop ] [ stack-reserve 1 1 rot SUBI ] if ;
GENERIC: store-insn
GENERIC: load-insn
@ -22,10 +22,10 @@ M: int-regs return-reg drop 3 ;
M: int-regs load-insn drop 3 + 1 rot LWZ ;
M: float-regs store-insn
float-regs-size 4 = [ STFS ] [ STFD ] ifte ;
float-regs-size 4 = [ STFS ] [ STFD ] if ;
M: float-regs return-reg drop 1 ;
M: float-regs load-insn
>r 1+ 1 rot r> float-regs-size 4 = [ LFS ] [ LFD ] ifte ;
>r 1+ 1 rot r> float-regs-size 4 = [ LFS ] [ LFD ] if ;
M: %unbox generate-node ( vop -- )
[ 1 vop-in f compile-c-call ] keep
@ -43,4 +43,4 @@ M: %box generate-node ( vop -- )
M: %cleanup generate-node ( vop -- )
0 vop-in dup 0 =
[ drop ] [ stack-reserve 1 1 rot ADDI ] ifte ;
[ drop ] [ stack-reserve 1 1 rot ADDI ] if ;

2
library/compiler/ppc/assembler.factor
View File

@ -190,7 +190,7 @@ M: word BC >r 0 BC r> relative-14 ;
: LOAD ( n r -- )
#! PowerPC cannot load a 32 bit literal in one instruction.
>r dup dup HEX: ffff bitand = [ r> LI ] [ r> LOAD32 ] ifte ;
>r dup dup HEX: ffff bitand = [ r> LI ] [ r> LOAD32 ] if ;
! Floating point
: (FMR) >r 0 -rot 72 r> x-form 63 insn ;

4
library/compiler/ppc/generator.factor
View File

@ -37,14 +37,14 @@ M: %call-label generate-node ( vop -- )
: compile-call ( label -- )
#! Far C call for primitives, near C call for compiled defs.
dup primitive? [ word-addr 3 MTLR BLRL ] [ BL ] ifte ;
dup primitive? [ word-addr 3 MTLR BLRL ] [ BL ] if ;
M: %call generate-node ( vop -- )
vop-label dup postpone-word compile-call ;
: compile-jump ( label -- )
#! For tail calls. IP not saved on C stack.
dup primitive? [ word-addr 3 MTCTR BCTR ] [ B ] ifte ;
dup primitive? [ word-addr 3 MTCTR BCTR ] [ B ] if ;
M: %jump generate-node ( vop -- )
vop-label dup postpone-word compile-epilogue compile-jump ;

4
library/compiler/relocate.factor
View File

@ -23,14 +23,14 @@ SYMBOL: relocation-table
: rel-address ( rel/abs 16/16 -- )
#! Relocate address just compiled.
over 1 = [ 2drop ] [ 2 rel-type, relocating 0 rel, ] ifte ;
over 1 = [ 2drop ] [ 2 rel-type, relocating 0 rel, ] if ;
: rel-word ( word rel/abs 16/16 -- )
pick primitive? [
rel-primitive
] [
rot drop rel-address
] ifte ;
] if ;
: rel-userenv ( n 16/16 -- )
0 swap 3 rel-type, relocating rel, ;

4
library/compiler/stack.factor
View File

@ -16,7 +16,7 @@ M: object load-value ( vreg n value -- )
drop %peek-d , ;
: load-literal ( vreg obj -- )
dup immediate? [ %immediate ] [ %indirect ] ifte , ;
dup immediate? [ %immediate ] [ %indirect ] if , ;
M: literal load-value ( vreg n value -- )
nip literal-value load-literal ;
@ -80,7 +80,7 @@ SYMBOL: live-r
swapd (vregs>stacks) (vregs>stacks) ;
: ?nth ( n seq -- elt/f )
2dup length >= [ 2drop f ] [ nth ] ifte ;
2dup length >= [ 2drop f ] [ nth ] if ;
: live-stores ( instack outstack -- stack )
#! Avoid storing a value into its former position.

2
library/compiler/vops.factor
View File

@ -16,7 +16,7 @@ namespaces parser sequences words ;
gensym dup t "label" set-word-prop ;
: label? ( obj -- ? )
dup word? [ "label" word-prop ] [ drop f ] ifte ;
dup word? [ "label" word-prop ] [ drop f ] if ;
! A location is a virtual register or a stack slot. We can
! ask a VOP if it reads or writes a location.

4
library/compiler/x86/alien.factor
View File

@ -25,7 +25,7 @@ M: int-regs push-reg drop EAX PUSH ;
M: float-regs reg-size float-regs-size ;
M: float-regs push-reg
ESP swap reg-size [ SUB [ ESP ] ] keep
4 = [ FSTPS ] [ FSTPL ] ifte ;
4 = [ FSTPS ] [ FSTPL ] if ;
M: %unbox generate-node
dup 1 vop-in f compile-c-call 2 vop-in push-reg ;
@ -36,4 +36,4 @@ M: %box generate-node
1 vop-in ESP swap reg-size ADD ;
M: %cleanup generate-node
0 vop-in dup 0 = [ drop ] [ ESP swap ADD ] ifte ;
0 vop-in dup 0 = [ drop ] [ ESP swap ADD ] if ;

10
library/compiler/x86/assembler.factor
View File

@ -78,7 +78,7 @@ M: register displacement drop ;
( Indirect register operands -- eg, [ ECX ] )
PREDICATE: cons indirect
dup cdr [ drop f ] [ car register? ] ifte ;
dup cdr [ drop f ] [ car register? ] if ;
M: indirect modifier drop BIN: 00 ;
M: indirect register car register ;
@ -88,18 +88,18 @@ M: indirect canonicalize dup car EBP = [ drop [ EBP 0 ] ] when ;
( Displaced indirect register operands -- eg, [ EAX 4 ] )
PREDICATE: cons displaced
dup length 2 =
[ first2 integer? swap register? and ] [ drop f ] ifte ;
[ first2 integer? swap register? and ] [ drop f ] if ;
M: displaced modifier second byte? BIN: 01 BIN: 10 ? ;
M: displaced register car register ;
M: displaced displacement
second dup byte? [ compile-byte ] [ compile-cell ] ifte ;
second dup byte? [ compile-byte ] [ compile-cell ] if ;
M: displaced canonicalize
dup first EBP = not over second 0 = and [ first unit ] when ;
( Displacement-only operands -- eg, [ 1234 ] )
PREDICATE: cons disp-only
dup length 1 = [ car integer? ] [ drop f ] ifte ;
dup length 1 = [ car integer? ] [ drop f ] if ;
M: disp-only modifier drop BIN: 00 ;
M: disp-only register
@ -131,7 +131,7 @@ UNION: operand register indirect displaced disp-only ;
] [
compile-byte swap r> 1-operand
compile-cell
] ifte ;
] if ;
: immediate-8 ( dst imm code reg -- )
#! The 'reg' is not really a register, but a value for the

2
library/compiler/x86/fixnum.factor
View File

@ -27,7 +27,7 @@ memory namespaces words ;
literal-overflow
] [
computed-overflow
] ifte
] if
! Compute a result, this time it will fit.
dupd r> execute
! Create a bignum.

2
library/compiler/x86/stack.factor
View File

@ -17,7 +17,7 @@ M: %peek generate-node ( vop -- )
M: %replace generate-node ( vop -- )
dup 0 vop-out loc>operand swap 0 vop-in v>operand MOV ;
: (%inc) swap 0 vop-in cell * dup 0 > [ ADD ] [ neg SUB ] ifte ;
: (%inc) swap 0 vop-in cell * dup 0 > [ ADD ] [ neg SUB ] if ;
M: %inc-d generate-node ( vop -- ) ESI (%inc) ;

6
library/compiler/xt.factor
View File

@ -25,7 +25,7 @@ SYMBOL: compiled-xts
compiled-xts off ;
: compiled-xt ( word -- xt )
dup compiled-xts get assoc [ ] [ word-xt ] ?ifte ;
dup compiled-xts get assoc [ ] [ word-xt ] ?if ;
! When a word is encountered that has not been previously
! compiled, it is pushed onto this vector. Compilation stops
@ -124,8 +124,8 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
drop t
] [
compiled-xts get assoc
] ifte
] ifte ;
] if
] if ;
: fixup-xts ( -- )
deferred-xts get [ fixup ] each deferred-xts off ;

2
library/continuations.factor
View File

@ -36,7 +36,7 @@ TUPLE: continuation data c call name catch ;
[
continuation
dup continuation-data f over push f swap push t
] call 2swap ifte ; inline
] call 2swap if ; inline
: callcc0 ( quot -- | quot: continuation -- )
#! Call a quotation with the current continuation, which may

2
library/errors.factor
View File

@ -22,7 +22,7 @@ TUPLE: no-method object generic ;
: rethrow ( error -- )
#! Use rethrow when passing an error on from a catch block.
catchstack empty?
[ die "Can't happen" throw ] [ c> continue-with ] ifte ;
[ die "Can't happen" throw ] [ c> continue-with ] if ;
: cleanup ( try cleanup -- | try: -- | cleanup: -- )
#! Call the try quotation. If an exception is thrown in the

4
library/generic/early-generic.factor
View File

@ -8,11 +8,11 @@ DEFER: standard-combination
DEFER: math-combination
: delegate ( object -- delegate )
dup tuple? [ 3 slot ] [ drop f ] ifte ;
dup tuple? [ 3 slot ] [ drop f ] if ;
: set-delegate ( delegate tuple -- )
dup tuple? [
3 set-slot
] [
"Only tuples can have delegates" throw
] ifte ;
] if ;

20
library/generic/generic.factor
View File

@ -26,14 +26,14 @@ SYMBOL: builtins
swap "predicating" set-word-prop
] [
3drop
] ifte ;
] if ;
: superclass "superclass" word-prop ;
: members "members" word-prop ;
: (flatten) ( class -- )
dup members [ [ (flatten) ] each ] [ dup set ] ?ifte ;
dup members [ [ (flatten) ] each ] [ dup set ] ?if ;
: flatten ( class -- classes )
#! Outputs a sequence of classes whose union is this class.
@ -43,7 +43,7 @@ SYMBOL: builtins
#! Only valid for a flattened class.
flatten [
car dup superclass
[ (types) ] [ "type" word-prop dup set ] ?ifte
[ (types) ] [ "type" word-prop dup set ] ?if
] hash-each ;
: types ( class -- types )
@ -52,7 +52,7 @@ SYMBOL: builtins
DEFER: class<
: superclass< ( cls1 cls2 -- ? )
>r superclass r> over [ class< ] [ 2drop f ] ifte ;
>r superclass r> over [ class< ] [ 2drop f ] if ;
: (class<) ( cls1 cls2 -- ? )
[ flatten hash-keys ] 2apply
@ -70,7 +70,7 @@ DEFER: class<
}@ cond ;
: class-compare ( cls1 cls2 -- -1/0/1 )
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] ifte ;
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
: methods ( generic -- alist )
"methods" word-prop hash>alist [ 2car class-compare ] sort ;
@ -105,7 +105,7 @@ M: generic definer drop \ G: ;
: init-methods ( word -- )
dup "methods" word-prop
[ drop ] [ {{ }} clone "methods" set-word-prop ] ifte ;
[ drop ] [ {{ }} clone "methods" set-word-prop ] if ;
! Defining generic words
@ -136,8 +136,8 @@ M: generic definer drop \ G: ;
(builtin-supertypes)
] [
dup set
] ?ifte
] ?ifte ;
] ?if
] ?if ;
: builtin-supertypes ( class -- classes )
#! Outputs a sequence of builtin classes whose union is the
@ -164,7 +164,7 @@ M: generic definer drop \ G: ;
#! Is this class the smallest class in the sequence?
[ dupd classes-intersect? ] subset
[ class-compare neg ] sort
tuck [ class< ] all-with? [ first ] [ drop f ] ifte ;
tuck [ class< ] all-with? [ first ] [ drop f ] if ;
: define-class ( class -- )
dup t "class" set-word-prop
@ -184,7 +184,7 @@ M: generic definer drop \ G: ;
pick define-class
3dup nip "definition" set-word-prop
pick superclass "predicate" word-prop
[ \ dup , % , [ drop f ] , \ ifte , ] [ ] make
[ \ dup , % , [ drop f ] , \ if , ] [ ] make
define-predicate ;
PREDICATE: word predicate "definition" word-prop ;

12
library/generic/math-combination.factor
View File

@ -25,8 +25,8 @@ math namespaces sequences words ;
drop "coercer" word-prop
] [
2drop [ ]
] ifte
] ifte ;
] if
] if ;
TUPLE: no-math-method left right generic ;
@ -36,7 +36,7 @@ TUPLE: no-math-method left right generic ;
: applicable-method ( generic class -- quot )
over "methods" word-prop hash [ ] [
literalize [ no-math-method ] cons
] ?ifte ;
] ?if ;
: object-method ( generic -- quot )
object reintern applicable-method ;
@ -48,7 +48,7 @@ TUPLE: no-math-method left right generic ;
r> swap append
] [
2drop object-method
] ifte ;
] if ;
: math-vtable ( picker quot -- )
[
@ -58,7 +58,7 @@ TUPLE: no-math-method left right generic ;
] [ ] make ; inline
: math-class? ( object -- ? )
dup word? [ "math-priority" word-prop ] [ drop f ] ifte ;
dup word? [ "math-priority" word-prop ] [ drop f ] if ;
: math-combination ( word -- vtable )
\ over [
@ -66,7 +66,7 @@ TUPLE: no-math-method left right generic ;
\ dup [ >r 2dup r> math-method ] math-vtable
] [
over object-method
] ifte nip
] if nip
] math-vtable nip ;
PREDICATE: generic 2generic ( word -- ? )

2
library/generic/slots.factor
View File

@ -18,7 +18,7 @@ parser sequences strings words ;
>r swap >fixnum r> cons define-typecheck
] [
2drop 2drop
] ifte ;
] if ;
: define-reader ( class slot reader -- )
[ slot ] define-slot-word ;

14
library/generic/standard-combination.factor
View File

@ -8,11 +8,11 @@ namespaces sequences vectors words ;
: empty-method ( picker word -- method )
over [ dup ] = [
[
[ dup delegate ] % dup unit , error-method , \ ?ifte ,
[ dup delegate ] % dup unit , error-method , \ ?if ,
] [ ] make
] [
error-method
] ifte ;
] if ;
: class-predicates ( picker assoc -- assoc )
[ uncons >r "predicate" word-prop append r> cons ] map-with ;
@ -30,14 +30,14 @@ namespaces sequences vectors words ;
cdr simplify-alist
] [
uncons >r cdr nip r>
] ifte
] if
] [
nip car cdr [ ]
] ifte ;
] if ;
: vtable-methods ( picker alist-seq -- alist-seq )
dup length [
type>class [ swap simplify-alist ] [ car cdr [ ] ] ifte*
type>class [ swap simplify-alist ] [ car cdr [ ] ] if*
>r over r> class-predicates alist>quot
] 2map nip ;
@ -67,8 +67,8 @@ namespaces sequences vectors words ;
small-generic
] [
num-types \ type big-generic
] ifte
] ifte ;
] if
] if ;
: simple-combination ( word -- quot )
[ dup ] standard-combination ;

16
library/generic/tuple.factor
View File

@ -14,10 +14,10 @@ words ;
! slot 3 - the delegate tuple, or f
: class ( object -- class )
dup tuple? [ 2 slot ] [ type type>class ] ifte ; inline
dup tuple? [ 2 slot ] [ type type>class ] if ; inline
: class-tuple ( object -- class )
dup tuple? [ 2 slot ] [ drop f ] ifte ; inline
dup tuple? [ 2 slot ] [ drop f ] if ; inline
: tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top
@ -34,10 +34,10 @@ words ;
#! forget the old definition.
>r "in" get lookup dup [
dup "tuple-size" word-prop r> length 2 + =
[ drop ] [ forget-tuple ] ifte
[ drop ] [ forget-tuple ] if
] [
r> 2drop
] ifte ;
] if ;
: delegate-slots @{ @{ 3 delegate set-delegate }@ }@ ;
@ -84,8 +84,8 @@ M: tuple = ( obj tuple -- ? )
2dup eq? [
2drop t
] [
over tuple? [ array= ] [ 2drop f ] ifte
] ifte ;
over tuple? [ array= ] [ 2drop f ] if
] if ;
PREDICATE: word tuple-class "tuple-size" word-prop ;
@ -95,5 +95,5 @@ PREDICATE: word tuple-class "tuple-size" word-prop ;
[ call ] 2keep rot [
2drop t
] [
over [ >r delegate r> is? ] [ 2drop f ] ifte
] ifte ; inline
over [ >r delegate r> is? ] [ 2drop f ] if
] if ; inline

6
library/help/tutorial.factor
View File

@ -225,13 +225,13 @@ M: general-list tutorial-line
""
[ " ... condition ... [ ... false case ... ] unless" ]
""
"The 'ifte' conditional takes action on both branches:"
"The 'if' conditional takes action on both branches:"
""
[ " ... condition ... [ ... ] [ ... ] ifte" ]
[ " ... condition ... [ ... ] [ ... ] if" ]
] [
"* Combinators"
"--"
"ifte, when, unless are words that take lists of code as input."
"if, when, unless are words that take lists of code as input."
""
"Lists of code are called ``quotations''."
"Words that take quotations are called ``combinators''."

4
library/httpd/browser-responder.factor
View File

@ -35,7 +35,7 @@ USING: html cont-responder kernel io namespaces words lists prettyprint
"<option selected>" write
] [
"<option>" write
] ifte
] if
chars>entities write
"</option>\n" write drop ;
@ -116,4 +116,4 @@ USING: html cont-responder kernel io namespaces words lists prettyprint
"word" swap assoc
] [
"browser-responder" "browse"
] ifte* browse ;
] if* browse ;

8
library/httpd/cont-responder.factor
View File

@ -85,7 +85,7 @@ TUPLE: item expire? quot id time-added ;
continuation-table remove-hash
] [
drop
] ifte
] if
] hash-each-with ;
: expirable ( quot -- t quot )
@ -152,7 +152,7 @@ DEFER: show
item-quot
] [
[ expired-page-handler ]
] ifte* >callable ;
] if* >callable ;
: resume-continuation ( value id -- )
#! Call the continuation associated with the given id,
@ -222,7 +222,7 @@ SYMBOL: callback-cc
] callcc1 drop
] [
t post-refresh-get? set
] ifte ;
] if ;
: show ( quot -- namespace )
#! Call the quotation with the URL associated with the current
@ -271,7 +271,7 @@ SYMBOL: root-continuation
resume-continuation
] [
expired-page-handler
] ifte*
] if*
] with-exit-continuation [ write flush ] when* ;
: callback-quot ( quot -- quot )

16
library/httpd/file-responder.factor
View File

@ -18,14 +18,14 @@ io strings ;
drop
] [
<file-reader> stdio get stream-copy
] ifte ;
] if ;
: serve-file ( filename -- )
dup mime-type dup "application/x-factor-server-page" = [
drop run-file
] [
serve-static
] ifte ;
] if ;
: file-link. ( text path -- )
file swons unit format ;
@ -45,7 +45,7 @@ io strings ;
drop
] [
"request" get [ directory. ] simple-html-document
] ifte ;
] if ;
: serve-directory ( filename -- )
"/" ?tail [
@ -53,13 +53,13 @@ io strings ;
nip serve-file
] [
drop list-directory
] ifte
] if
] [
drop directory-no/
] ifte ;
] if ;
: serve-object ( filename -- )
dup directory? [ serve-directory ] [ serve-file ] ifte ;
dup directory? [ serve-directory ] [ serve-file ] if ;
: file-responder ( filename -- )
"doc-root" get [
@ -67,7 +67,7 @@ io strings ;
serve-object
] [
drop "404 not found" httpd-error
] ifte
] if
] [
drop "404 doc-root not set" httpd-error
] ifte ;
] if ;

10
library/httpd/html.factor
View File

@ -16,7 +16,7 @@ presentation sequences strings styles words ;
: chars>entities ( str -- str )
#! Convert <, >, &, ' and " to HTML entities.
[
[ dup html-entities assoc [ % ] [ , ] ?ifte ] each
[ dup html-entities assoc [ % ] [ , ] ?if ] each
] "" make ;
: hex-color, ( triplet -- )
@ -56,7 +56,7 @@ presentation sequences strings styles words ;
drop call
] [
<span =style span> call </span>
] ifte ;
] if ;
: resolve-file-link ( path -- link )
#! The file responder needs relative links not absolute
@ -73,7 +73,7 @@ presentation sequences strings styles words ;
<a file-link-href =href a> call </a>
] [
call
] ifte* ;
] if* ;
: browser-link-href ( word -- href )
dup word-name swap word-vocabulary
@ -89,13 +89,13 @@ presentation sequences strings styles words ;
<a browser-link-href =href a> call </a>
] [
drop call
] ifte ;
] if ;
TUPLE: html-stream ;
M: html-stream stream-write1 ( char stream -- )
[
dup html-entities assoc [ write ] [ write1 ] ?ifte
dup html-entities assoc [ write ] [ write1 ] ?if
] with-wrapper ;
M: html-stream stream-format ( str style stream -- )

4
library/httpd/http-client.factor
View File

@ -6,13 +6,13 @@ io strings ;
: parse-host ( url -- host port )
#! Extract the host name and port number from an HTTP URL.
":" split1 [ string>number ] [ 80 ] ifte* ;
":" split1 [ string>number ] [ 80 ] if* ;
: parse-url ( url -- host resource )
"http://" ?head [
"URL must begin with http://" throw
] unless
"/" split1 [ "/" swap append ] [ "/" ] ifte* ;
"/" split1 [ "/" swap append ] [ "/" ] if* ;
: parse-response ( line -- code )
"HTTP/" ?head [ " " split1 nip ] when

12
library/httpd/http-common.factor
View File

@ -4,11 +4,11 @@ USING: errors kernel lists math namespaces parser sequences
io strings ;
: header-line ( alist line -- alist )
": " split1 dup [ cons swons ] [ 2drop ] ifte ;
": " split1 dup [ cons swons ] [ 2drop ] if ;
: (read-header) ( alist -- alist )
readln dup
empty? [ drop ] [ header-line (read-header) ] ifte ;
empty? [ drop ] [ header-line (read-header) ] if ;
: read-header ( -- alist )
[ ] (read-header) ;
@ -20,7 +20,7 @@ io strings ;
,
] [
CHAR: % , >hex 2 CHAR: 0 pad-left %
] ifte
] if
] each
] "" make ;
@ -33,7 +33,7 @@ io strings ;
2drop
] [
>r 1+ dup 2 + r> subseq catch-hex> [ , ] when*
] ifte ;
] if ;
: url-decode-% ( index str -- index str )
2dup url-decode-hex >r 3 + r> ;
@ -49,8 +49,8 @@ io strings ;
drop url-decode-%
] [
url-decode-+-or-other
] ifte url-decode-iter
] ifte ;
] if url-decode-iter
] if ;
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make ;

6
library/httpd/httpd.factor
View File

@ -14,7 +14,7 @@ sequences ;
>r (url>path) "?" r> append3
] [
drop (url>path)
] ifte ;
] if ;
: secure-path ( path -- path )
".." over subseq? [ drop f ] when ;
@ -44,10 +44,10 @@ sequences ;
swap handle-request
] [
2drop bad-request
] ifte
] if
] [
2drop bad-request
] ifte ;
] if ;
: httpd ( port -- )
\ httpd [

6
library/httpd/responder.factor
View File

@ -24,7 +24,7 @@ SYMBOL: responders
: httpd-error ( error -- )
#! This must be run from handle-request
error-head
"head" "method" get = [ drop ] [ terpri error-body ] ifte ;
"head" "method" get = [ drop ] [ terpri error-body ] if ;
: bad-request ( -- )
[
@ -150,7 +150,7 @@ SYMBOL: responders
] [
! Just a responder name by itself
drop "request" get "/" append redirect drop
] ifte ;
] if ;
: serve-responder ( method path host -- )
#! Responder paths come in two forms:
@ -161,7 +161,7 @@ SYMBOL: responders
serve-explicit-responder
] [
serve-default-responder
] ifte
] if
] bind ;
: no-such-responder ( -- )

8
library/inference/branches.factor
View File

@ -15,16 +15,16 @@ namespaces parser prettyprint sequences strings vectors words ;
: unify-values ( seq -- value )
#! If all values in list are equal, return the value.
#! Otherwise, unify.
dup all-eq? [ first ] [ drop <value> ] ifte ;
dup all-eq? [ first ] [ drop <value> ] if ;
: unify-stacks ( seq -- stack )
#! Replace differing literals in stacks with unknown
#! results.
[ ] subset dup empty?
[ drop f ] [ unify-lengths flip [ unify-values ] map ] ifte ;
[ drop f ] [ unify-lengths flip [ unify-values ] map ] if ;
: balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] ifte ] 2map
[ dup [ length - ] [ 2drop f ] if ] 2map
[ ] subset all-equal? ;
: unify-in-d ( seq -- n )
@ -44,7 +44,7 @@ namespaces parser prettyprint sequences strings vectors words ;
unify-stacks >r unify-in-d r>
] [
unbalanced-branches
] ifte ;
] if ;
: datastack-effect ( seq -- )
dup [ d-in swap hash ] map

20
library/inference/call-optimizers.factor
View File

@ -19,22 +19,22 @@ math math-internals sequences words ;
dup node-param "foldable" word-prop [
dup node-in-d [
dup literal?
[ 2drop t ] [ swap node-literals ?hash* ] ifte
[ 2drop t ] [ swap node-literals ?hash* ] if
] all-with?
] [
drop f
] ifte ;
] if ;
: literal-in-d ( #call -- inputs )
dup node-in-d [
dup literal?
[ nip literal-value ] [ swap node-literals ?hash ] ifte
[ nip literal-value ] [ swap node-literals ?hash ] if
] map-with ;
: partial-eval ( #call -- node )
dup literal-in-d over node-param
[ with-datastack ] catch
[ 3drop t ] [ inline-literals ] ifte ;
[ 3drop t ] [ inline-literals ] if ;
: flip-subst ( not -- )
#! Note: cloning the vectors, since subst-values will modify
@ -43,20 +43,20 @@ math math-internals sequences words ;
[ node-out-d clone ] keep
subst-values ;
: flip-branches ( not -- #ifte )
#! If a not is followed by an #ifte, flip branches and
: flip-branches ( not -- #if )
#! If a not is followed by an #if, flip branches and
#! remove the note.
dup flip-subst node-successor dup
dup node-children first2 swap 2array swap set-node-children ;
\ not {
{ [ dup node-successor #ifte? ] [ flip-branches ] }
{ [ dup node-successor #if? ] [ flip-branches ] }
} define-optimizers
: disjoint-eq? ( node -- ? )
dup node-classes swap node-in-d
[ swap ?hash ] map-with
first2 2dup and [ classes-intersect? not ] [ 2drop f ] ifte ;
first2 2dup and [ classes-intersect? not ] [ 2drop f ] if ;
\ eq? {
{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
@ -70,7 +70,7 @@ SYMBOL: @
: literals-match? ( values template -- ? )
[
over literal? [ >r literal-value r> ] [ nip @ ] ifte =
over literal? [ >r literal-value r> ] [ nip @ ] if =
] 2map [ ] all? ;
: values-match? ( values template -- ? )
@ -88,7 +88,7 @@ SYMBOL: @
second swap dataflow-with [ subst-node ] keep
] [
3drop f
] ifte ;
] if ;
[ + fixnum+ bignum+ float+ ] @{
@{ @{ @ 0 }@ [ drop ] }@

8
library/inference/class-infer.factor
View File

@ -96,8 +96,8 @@ M: node child-ties ( node -- seq )
ties get set-hash
] [
2drop
] ifte
] ifte ;
] if
] if ;
\ make-tuple [
dup node-in-d first literal-value 1array
@ -109,7 +109,7 @@ M: node child-ties ( node -- seq )
] [
node-param "infer-effect" word-prop second
dup integer? [ drop f ] when
] ?ifte ;
] ?if ;
M: #call infer-classes* ( node -- )
dup node-param [
@ -122,7 +122,7 @@ M: #shuffle infer-classes* ( node -- )
node-out-d [ literal? ] subset
[ [ literal-value ] keep set-value-literal ] each ;
M: #ifte child-ties ( node -- seq )
M: #if child-ties ( node -- seq )
node-in-d first dup general-t <class-tie>
swap f <literal-tie> 2array ;

24
library/inference/dataflow.factor
View File

@ -91,9 +91,9 @@ C: #return make-node ;
meta-d get clone in-node <#return>
[ set-node-param ] keep ;
TUPLE: #ifte ;
C: #ifte make-node ;
: #ifte ( in -- node ) 1 d-tail in-node <#ifte> ;
TUPLE: #if ;
C: #if make-node ;
: #if ( in -- node ) 1 d-tail in-node <#if> ;
TUPLE: #dispatch ;
C: #dispatch make-node ;
@ -128,7 +128,7 @@ SYMBOL: current-node
] [
! first node
dup dataflow-graph set current-node set
] ifte ;
] if ;
: nest-node ( -- dataflow current )
dataflow-graph get dataflow-graph off
@ -154,15 +154,15 @@ SYMBOL: current-node
2dup node-out-d member? >r node-out-r member? r> or ;
: last-node ( node -- last )
dup node-successor [ last-node ] [ ] ?ifte ;
dup node-successor [ last-node ] [ ] ?if ;
: penultimate-node ( node -- penultimate )
dup node-successor dup [
dup node-successor
[ nip penultimate-node ] [ drop ] ifte
[ nip penultimate-node ] [ drop ] if
] [
2drop f
] ifte ;
] if ;
: drop-inputs ( node -- #shuffle )
node-in-d clone in-node <#shuffle> ;
@ -177,7 +177,7 @@ SYMBOL: current-node
node-successor swap each-node
] [
2drop
] ifte ; inline
] if ; inline
: each-node-with ( obj node quot -- | quot: obj node -- )
swap [ with ] each-node 2drop ; inline
@ -191,13 +191,13 @@ SYMBOL: current-node
>r node-successor r> all-nodes?
] [
2drop f
] ifte
] if
] [
2drop f
] ifte
] if
] [
2drop t
] ifte ; inline
] if ; inline
: all-nodes-with? ( obj node quot -- ? | quot: obj node -- ? )
swap [ with rot ] all-nodes? 2nip ; inline
@ -216,7 +216,7 @@ SYMBOL: current-node
[
dup #call?
[ [ node-history ?push ] keep set-node-history ]
[ 2drop ] ifte
[ 2drop ] if
] each-node-with ;
: (clone-node) ( node -- node )

6
library/inference/inference.factor
View File

@ -34,7 +34,7 @@ M: value literal-value ( value -- )
! Word properties that affect inference:
! - infer-effect -- must be set. controls number of inputs
! expected, and number of outputs produced.
! - infer - quotation with custom inference behavior; ifte uses
! - infer - quotation with custom inference behavior; if uses
! this. Word is passed on the stack.
! Vector of results we had to add to the datastack. Ie, the
@ -50,7 +50,7 @@ SYMBOL: d-in
: add-inputs ( n stack -- stack )
tuck required-inputs dup 0 >
[ value-vector swap append ] [ drop ] ifte ;
[ value-vector swap append ] [ drop ] if ;
: ensure-values ( n -- )
dup meta-d get required-inputs d-in [ + ] change
@ -89,7 +89,7 @@ M: wrapper apply-object wrapped apply-literal ;
: infer-quot ( quot -- )
#! Recursive calls to this word are made for nested
#! quotations.
[ active? [ apply-object t ] [ drop f ] ifte ] all? drop ;
[ active? [ apply-object t ] [ drop f ] if ] all? drop ;
: infer-quot-value ( rstate quot -- )
recursive-state get >r swap recursive-state set

8
library/inference/inline-methods.factor
View File

@ -38,9 +38,9 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
first swap node-param order min-class
] [
2drop f
] ifte
] ifte
] ifte ;
] if
] if
] if ;
: will-inline ( node -- quot )
dup inlining-class swap node-param "methods" word-prop hash ;
@ -66,7 +66,7 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
>r dup node-in-d node-classes* first r> related?
] [
2drop f
] ifte ;
] if ;
: optimize-predicate ( #call -- node )
dup node-param "predicating" word-prop >r

6
library/inference/kill-literals.factor
View File

@ -41,7 +41,7 @@ M: f returns* drop ;
: kill-node ( values node -- )
over hash-size 0 >
[ [ remove-values ] each-node-with ] [ 2drop ] ifte ;
[ [ remove-values ] each-node-with ] [ 2drop ] if ;
! Generic nodes
M: node literals* ( node -- ) drop @{ }@ ;
@ -60,7 +60,7 @@ M: #return returns* , ;
M: #return live-values* ( node -- seq )
#! Values returned by local labels can be killed.
dup node-param [ drop @{ }@ ] [ delegate live-values* ] ifte ;
dup node-param [ drop @{ }@ ] [ delegate live-values* ] if ;
! nodes that don't use their input values directly
UNION: #killable #shuffle #call-label #merge #values ;
@ -75,7 +75,7 @@ M: #entry live-values* ( node -- seq )
node-out-d ;
! branching
UNION: #branch #ifte #dispatch ;
UNION: #branch #if #dispatch ;
M: #branch returns* ( node -- ) node-children [ returns* ] each ;

12
library/inference/known-words.factor
View File

@ -6,8 +6,8 @@ prettyprint ;
! We transform calls to these words into 'branched' forms;
! eg, there is no VOP for fixnum<=, only fixnum<= followed
! by an #ifte, so if we have a 'bare' fixnum<= we add
! [ t ] [ f ] ifte at the end.
! by an #if, so if we have a 'bare' fixnum<= we add
! [ t ] [ f ] if at the end.
! This transformation really belongs in the optimizer, but it
! is simpler to do it here.
@ -33,7 +33,7 @@ prettyprint ;
: manual-branch ( word -- )
dup "infer-effect" word-prop consume/produce
[ [ t ] [ f ] ifte ] infer-quot ;
[ [ t ] [ f ] if ] infer-quot ;
{ fixnum<= fixnum< fixnum>= fixnum> eq? } [
dup dup literalize [ manual-branch ] cons
@ -53,11 +53,11 @@ prettyprint ;
pop-literal unit infer-quot-value
] "infer" set-word-prop
\ ifte [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop
\ if [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop
\ ifte [
\ if [
2 #drop node, pop-d pop-d swap 2array
#ifte pop-d drop infer-branches
#if pop-d drop infer-branches
] "infer" set-word-prop
\ cond [ [ object ] [ ] ] "infer-effect" set-word-prop

20
library/inference/optimizer.factor
View File

@ -12,7 +12,7 @@ GENERIC: optimize-node* ( node -- node/t )
: keep-optimizing ( node -- node ? )
dup optimize-node* dup t =
[ drop f ] [ nip keep-optimizing t or ] ifte ;
[ drop f ] [ nip keep-optimizing t or ] if ;
DEFER: optimize-node
@ -27,7 +27,7 @@ DEFER: optimize-node
dup optimize-children >r
dup node-successor optimize-node >r
over set-node-successor r> r> r> or or
] [ r> ] ifte ;
] [ r> ] if ;
: optimize-1 ( dataflow -- dataflow ? )
recursive-state off
@ -44,7 +44,7 @@ DEFER: optimize-node
] with-scope ;
: prune-if ( node quot -- successor/t )
over >r call [ r> node-successor ] [ r> drop t ] ifte ;
over >r call [ r> node-successor ] [ r> drop t ] if ;
inline
! Generic nodes
@ -60,7 +60,7 @@ M: node optimize-node* ( node -- t )
2drop t
] [
[ set-node-shuffle ] keep
] ifte ;
] if ;
M: #shuffle optimize-node* ( node -- node/t )
dup node-successor dup #shuffle? [
@ -68,11 +68,11 @@ M: #shuffle optimize-node* ( node -- node/t )
] [
drop [
dup node-in-d over node-out-d =
[ dup node-in-r swap node-out-r = ] [ drop f ] ifte
[ dup node-in-r swap node-out-r = ] [ drop f ] if
] prune-if
] ifte ;
] if ;
! #ifte
! #if
: static-branch? ( node -- lit ? )
node-in-d first dup literal? ;
@ -80,13 +80,13 @@ M: #shuffle optimize-node* ( node -- node/t )
over drop-inputs
[ >r swap node-children nth r> set-node-successor ] keep ;
M: #ifte optimize-node* ( node -- node )
M: #if optimize-node* ( node -- node )
dup static-branch?
[ literal-value 0 1 ? static-branch ] [ 2drop t ] ifte ;
[ literal-value 0 1 ? static-branch ] [ 2drop t ] if ;
! #values
: optimize-fold ( node -- node/t )
node-successor [ node-successor ] [ t ] ifte* ;
node-successor [ node-successor ] [ t ] if* ;
M: #values optimize-node* ( node -- node/t )
optimize-fold ;

14
library/inference/print-dataflow.factor
View File

@ -14,12 +14,12 @@ M: comment pprint* ( ann -- )
swap comment-node presented swons unit text ;
: comment, ( ? node text -- )
rot [ <comment> , ] [ 2drop ] ifte ;
rot [ <comment> , ] [ 2drop ] if ;
: values% ( prefix values -- )
[
swap %
dup literal? [ literal-value ] [ value-uid ] ifte
dup literal? [ literal-value ] [ value-uid ] if
unparse %
] each-with ;
@ -39,7 +39,7 @@ DEFER: dataflow>quot
: #call>quot ( ? node -- )
dup node-param dup
[ , dup effect-str comment, ] [ 3drop ] ifte ;
[ , dup effect-str comment, ] [ 3drop ] if ;
M: #call node>quot ( ? node -- ) #call>quot ;
@ -49,9 +49,9 @@ M: #label node>quot ( ? node -- )
[ "#label: " over node-param word-name append comment, ] 2keep
node-child swap dataflow>quot , \ call , ;
M: #ifte node>quot ( ? node -- )
[ "#ifte" comment, ] 2keep
node-children [ swap dataflow>quot ] map-with % \ ifte , ;
M: #if node>quot ( ? node -- )
[ "#if" comment, ] 2keep
node-children [ swap dataflow>quot ] map-with % \ if , ;
M: #dispatch node>quot ( ? node -- )
[ "#dispatch" comment, ] 2keep
@ -73,7 +73,7 @@ M: #terminate node>quot ( ? node -- ) "#terminate" comment, ;
2dup node>quot node-successor (dataflow>quot)
] [
2drop
] ifte ;
] if ;
: dataflow>quot ( node ? -- quot )
[ swap (dataflow>quot) ] [ ] make ;

2
library/inference/recursive-values.factor
View File

@ -8,7 +8,7 @@ GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* ( label node -- ) 2drop ;
M: #call-label collect-recursion* ( label node -- )
tuck node-param = [ node-in-d , ] [ drop ] ifte ;
tuck node-param = [ node-in-d , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
#! Collect the input stacks of all #call-label nodes that

8
library/inference/split-nodes.factor
View File

@ -1,7 +1,7 @@
IN: optimizer
USING: inference kernel sequences words ;
! #ifte --> X
! #if --> X
! |
! +--> Y
! |
@ -9,7 +9,7 @@ USING: inference kernel sequences words ;
! Becomes:
! #ifte
! #if
! |
! +--> Y --> X
! |
@ -28,7 +28,7 @@ M: node split-node* ( node -- ) drop ;
node-successor subst-values
] [
2drop
] ifte ;
] if ;
: subst-node ( old new -- )
#! The last node of 'new' becomes 'old', then values are
@ -49,7 +49,7 @@ M: node split-node* ( node -- ) drop ;
[ >r clone-node r> subst-node ] each-with
f swap set-node-successor ;
M: #ifte split-node* ( node -- )
M: #if split-node* ( node -- )
split-branch ;
M: #dispatch split-node* ( node -- )

24
library/inference/words.factor
View File

@ -78,11 +78,11 @@ M: compound apply-word ( word -- )
] [
dupd consume/produce
"terminates" word-prop [ terminate ] when
] ifte*
] if*
] [
apply-word
] ifte*
] ifte ;
] if*
] if ;
M: word apply-object ( word -- )
apply-default ;
@ -94,11 +94,11 @@ M: symbol apply-object ( word -- )
over "inline" word-prop [
meta-d get clone >r
over inline-block drop
[ #call-label ] [ #call ] ?ifte
[ #call-label ] [ #call ] ?if
r> over set-node-in-d node,
] [
drop dup t infer-compound nip "base-case" set-word-prop
] ifte ;
] if ;
: base-case ( word label -- )
[ inferring-base-case on (base-case) ]
@ -113,7 +113,7 @@ M: symbol apply-object ( word -- )
: notify-base-case ( -- )
base-case-continuation get
[ t swap continue-with ] [ no-base-case ] ifte* ;
[ t swap continue-with ] [ no-base-case ] if* ;
: recursive-word ( word [[ label quot ]] -- )
#! Handle a recursive call, by either applying a previously
@ -129,9 +129,9 @@ M: symbol apply-object ( word -- )
notify-base-case
] [
car base-case
] ifte
] ifte*
] ifte* ;
] if
] if*
] if* ;
: splice-node ( node -- )
dup node-successor [
@ -146,7 +146,7 @@ M: symbol apply-object ( word -- )
node,
] [
node-child node-successor splice-node
] ifte ;
] if ;
M: compound apply-object ( word -- )
#! Apply the word's stack effect to the inferencer state.
@ -154,5 +154,5 @@ M: compound apply-object ( word -- )
recursive-word
] [
dup "inline" word-prop
[ inline-block block, ] [ apply-default ] ifte
] ifte* ;
[ inline-block block, ] [ apply-default ] if
] if* ;

4
library/io/buffer.factor
View File

@ -70,10 +70,10 @@ C: buffer ( size -- buffer )
buffer-extend
] [
"Buffer overflow" throw
] ifte
] if
] [
2drop
] ifte ;
] if ;
: >buffer ( string buffer -- )
over length over check-overflow

2
library/io/c-streams.factor
View File

@ -25,7 +25,7 @@ M: c-stream stream-flush ( stream -- )
c-stream-out [ fflush ] when* ;
M: c-stream stream-finish ( stream -- )
dup c-stream-flush? [ stream-flush ] [ drop ] ifte ;
dup c-stream-flush? [ stream-flush ] [ drop ] if ;
M: c-stream stream-close ( stream -- )
dup c-stream-in [ fclose ] when*

2
library/io/duplex-stream.factor
View File

@ -9,7 +9,7 @@ M: duplex-stream stream-flush
M: duplex-stream stream-finish
dup duplex-stream-flush?
[ duplex-stream-out stream-flush ] [ drop ] ifte ;
[ duplex-stream-out stream-flush ] [ drop ] if ;
M: duplex-stream stream-readln
duplex-stream-in stream-readln ;

4
library/io/files.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io
USING: hashtables kernel lists namespaces sequences strings ;
USING: hashtables kernel lists math namespaces sequences strings ;
! Words for accessing filesystem meta-data.
@ -19,7 +19,7 @@ USING: hashtables kernel lists namespaces sequences strings ;
: file-length ( file -- length ) stat third ;
: file-extension ( filename -- extension )
"." split cdr dup [ peek ] when ;
"." split dup length 1 <= [ drop f ] [ peek ] if ;
: resource-path ( path -- path )
"resource-path" get [ "." ] unless* swap path+ ;

14
library/io/lines.factor
View File

@ -17,18 +17,18 @@ C: line-reader ( stream -- line ) [ set-delegate ] keep ;
drop t swap set-line-reader-cr
] [
dup CHAR: \n = [
drop dup cr> [ (readln) ] [ drop ] ifte
drop dup cr> [ (readln) ] [ drop ] if
] [
, (readln)
] ifte
] ifte
] if
] if
] [
2drop
] ifte ;
] if ;
M: line-reader stream-readln ( line -- string )
[ f swap (readln) ] "" make
dup empty? [ f ? ] [ nip ] ifte ;
dup empty? [ f ? ] [ nip ] if ;
M: line-reader stream-read ( count line -- string )
[ delegate stream-read ] keep dup cr> [
@ -36,10 +36,10 @@ M: line-reader stream-read ( count line -- string )
drop
] [
>r 1 swap tail r> stream-read1 [ add ] when*
] ifte
] if
] [
drop
] ifte ;
] if ;
: (lines) ( seq -- seq )
readln [ over push (lines) ] when* ;

2
library/io/stream.factor
View File

@ -28,7 +28,7 @@ GENERIC: set-timeout ( timeout stream -- )
: (stream-copy) ( in out -- )
4096 pick stream-read
[ over stream-write (stream-copy) ] [ 2drop ] ifte* ;
[ over stream-write (stream-copy) ] [ 2drop ] if* ;
: stream-copy ( in out -- )
[ 2dup (stream-copy) ] [ stream-close stream-close ] cleanup ;

4
library/io/string-streams.factor
View File

@ -16,7 +16,7 @@ M: sbuf stream-finish drop ;
! Reversed string buffers support the stream input protocol.
M: sbuf stream-read1 ( sbuf -- char/f )
dup empty? [ drop f ] [ pop ] ifte ;
dup empty? [ drop f ] [ pop ] if ;
M: sbuf stream-read ( count sbuf -- string )
dup empty? [
@ -24,7 +24,7 @@ M: sbuf stream-read ( count sbuf -- string )
] [
swap over length min empty-sbuf
[ [ drop dup pop ] inject drop ] keep
] ifte ;
] if ;
: <string-reader> ( string -- stream )
<reversed> >sbuf <line-reader> ;

24
library/kernel.factor
View File

@ -30,7 +30,7 @@ M: object clone ;
: ? ( cond t f -- t/f )
#! Push t if cond is true, otherwise push f.
rot [ drop ] [ nip ] ifte ; inline
rot [ drop ] [ nip ] if ; inline
: >boolean t f ? ; inline
: and ( a b -- a&b ) f ? ; inline
@ -74,38 +74,38 @@ M: object clone ;
: 2apply ( x y quot -- | quot: x/y -- )
tuck 2slip call ; inline
: ifte* ( cond true false -- | true: cond -- | false: -- )
#! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte
pick [ drop call ] [ 2nip call ] ifte ; inline
: if* ( cond true false -- | true: cond -- | false: -- )
#! [ X ] [ Y ] if* ==> dup [ X ] [ drop Y ] if
pick [ drop call ] [ 2nip call ] if ; inline
: ?ifte ( default cond true false -- )
#! [ X ] [ Y ] ?ifte ==> dup [ nip X ] [ drop Y ] ifte
: ?if ( default cond true false -- )
#! [ X ] [ Y ] ?if ==> dup [ nip X ] [ drop Y ] if
>r >r dup [
nip r> r> drop call
] [
drop r> drop r> call
] ifte ; inline
] if ; inline
: unless ( cond quot -- | quot: -- )
#! Execute a quotation only when the condition is f. The
#! condition is popped off the stack.
[ ] swap ifte ; inline
[ ] swap if ; inline
: unless* ( cond quot -- | quot: -- )
#! If cond is f, pop it off the stack and evaluate the
#! quotation. Otherwise, leave cond on the stack.
over [ drop ] [ nip call ] ifte ; inline
over [ drop ] [ nip call ] if ; inline
: when ( cond quot -- | quot: -- )
#! Execute a quotation only when the condition is not f. The
#! condition is popped off the stack.
[ ] ifte ; inline
[ ] if ; inline
: when* ( cond quot -- | quot: cond -- )
#! If the condition is true, it is left on the stack, and
#! the quotation is evaluated. Otherwise, the condition is
#! popped off the stack.
dupd [ drop ] ifte ; inline
dupd [ drop ] if ; inline
: with ( obj quot elt -- obj quot )
#! Utility word for each-with, map-with.
@ -115,7 +115,7 @@ M: object clone ;
datastack slip set-datastack drop ;
M: wrapper = ( obj wrapper -- ? )
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] ifte ;
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
IN: kernel-internals

8
library/math/arc-trig-hyp.factor
View File

@ -15,10 +15,10 @@ USING: kernel math math-internals ;
: acosech recip asinh ; inline
: atanh dup 1+ swap 1- neg / log 2 / ; inline
: acoth recip atanh ; inline
: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ; inline
: asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ; inline
: acos dup <=1 [ facos ] [ asin pi 2 / swap - ] ifte ; inline
: atan dup <=1 [ fatan ] [ i * atanh i * ] ifte ; inline
: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] if ; inline
: asin dup <=1 [ fasin ] [ i * asinh -i * ] if ; inline
: acos dup <=1 [ facos ] [ asin pi 2 / swap - ] if ; inline
: atan dup <=1 [ fatan ] [ i * atanh i * ] if ; inline
: asec recip acos ; inline
: acosec recip asin ; inline
: acot recip atan ; inline

6
library/math/complex.factor
View File

@ -6,7 +6,7 @@ USING: errors generic kernel kernel-internals math ;
: (rect>) ( xr xi -- x )
#! Does not perform a check that the arguments are reals.
#! Do not use in your own code.
dup 0 number= [ drop ] [ <complex> ] ifte ; inline
dup 0 number= [ drop ] [ <complex> ] if ; inline
IN: math
@ -22,7 +22,7 @@ M: number = ( n n -- ? ) number= ;
(rect>)
] [
"Complex number must have real components" throw
] ifte ; inline
] if ; inline
: >rect ( x -- xr xi ) dup real swap imaginary ; inline
@ -49,7 +49,7 @@ IN: math-internals
[ [ real ] 2apply ] 2keep [ imaginary ] 2apply ; inline
M: complex number= ( x y -- ? )
2>rect number= [ number= ] [ 2drop f ] ifte ;
2>rect number= [ number= ] [ 2drop f ] if ;
: *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ; inline
: *im ( x y -- xi*yr xr*yi ) 2>rect >r * swap r> * ; inline

6
library/math/integer.factor
View File

@ -10,7 +10,7 @@ UNION: integer fixnum bignum ;
drop nip
] [
tuck /mod >r pick * swap >r swapd - r> r> (gcd)
] ifte ; inline
] if ; inline
: gcd ( x y -- a d )
#! Compute the greatest common divisor d and multiplier a
@ -29,7 +29,7 @@ UNION: integer fixnum bignum ;
IN: math-internals
: fraction> ( a b -- a/b )
dup 1 number= [ drop ] [ (fraction>) ] ifte ; inline
dup 1 number= [ drop ] [ (fraction>) ] if ; inline
: division-by-zero ( x y -- ) "Division by zero" throw ;
@ -39,7 +39,7 @@ M: integer / ( x y -- x/y )
] [
dup 0 < [ [ neg ] 2apply ] when
2dup gcd nip tuck /i >r /i r> fraction>
] ifte ;
] if ;
M: fixnum number=
#! Fixnums are immediate values, so equality testing is

14
library/math/math.factor
View File

@ -51,21 +51,21 @@ GENERIC: ceiling ( n -- n ) foldable
: rem ( x y -- x%y )
#! Like modulus, but always gives a positive result.
[ mod ] keep over 0 < [ + ] [ drop ] ifte ; inline
[ mod ] keep over 0 < [ + ] [ drop ] if ; inline
: sgn ( n -- -1/0/1 )
#! Push the sign of a real number.
dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ; foldable
dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] if ; foldable
GENERIC: abs ( z -- |z| ) foldable
GENERIC: absq ( n -- |n|^2 ) foldable
: align ( offset width -- offset )
2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ; inline
2dup mod dup 0 number= [ 2drop ] [ - + ] if ; inline
: (repeat) ( i n quot -- )
pick pick >=
[ 3drop ] [ [ swap >r call 1+ r> ] keep (repeat) ] ifte ;
[ 3drop ] [ [ swap >r call 1+ r> ] keep (repeat) ] if ;
inline
: repeat ( n quot -- | quot: n -- n )
@ -81,14 +81,14 @@ GENERIC: absq ( n -- |n|^2 ) foldable
dup dup neg bitand =
] [
drop f
] ifte ; foldable
] if ; foldable
: log2 ( n -- b )
#! Log base two for integers.
dup 0 <= [
"Input must be positive" throw
] [
dup 1 = [ drop 0 ] [ 2 /i log2 1+ ] ifte
] ifte ; foldable
dup 1 = [ drop 0 ] [ 2 /i log2 1+ ] if
] if ; foldable
GENERIC: number>string ( str -- num ) foldable

10
library/math/parse-numbers.factor
View File

@ -15,14 +15,14 @@ M: LETTER digit> CHAR: A - 10 + ;
M: object digit> not-a-number ;
: digit+ ( num digit base -- num )
2dup < [ rot * + ] [ not-a-number ] ifte ;
2dup < [ rot * + ] [ not-a-number ] if ;
: (base>) ( base str -- num )
dup empty? [
not-a-number
] [
0 [ digit> pick digit+ ] reduce nip
] ifte ;
] if ;
: base> ( str base -- num )
#! Convert a string to an integer. Throw an error if
@ -44,11 +44,11 @@ M: object digit> not-a-number ;
: hex> 16 base> ;
: >digit ( n -- ch )
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
: integer, ( num radix -- )
dup >r /mod >digit , dup 0 >
[ r> integer, ] [ r> 2drop ] ifte ;
[ r> integer, ] [ r> 2drop ] if ;
: >base ( num radix -- string )
#! Convert a number to a string in a certain base.
@ -57,7 +57,7 @@ M: object digit> not-a-number ;
swap neg swap integer, CHAR: - ,
] [
integer,
] ifte
] if
] "" make reverse ;
: >bin ( num -- string ) 2 >base ;

10
library/math/pow.factor
View File

@ -13,7 +13,7 @@ GENERIC: sqrt ( n -- n ) foldable
M: complex sqrt >polar swap fsqrt swap 2 / polar> ;
M: real sqrt dup 0 < [ neg fsqrt 0 swap rect> ] [ fsqrt ] ifte ;
M: real sqrt dup 0 < [ neg fsqrt 0 swap rect> ] [ fsqrt ] if ;
: norm ( vec -- n ) norm-sq sqrt ;
@ -37,7 +37,7 @@ M: number ^ ( z w -- z^w )
2drop
] [
2dup >r >r >r 1 bitand r> call r> -1 shift r> each-bit
] ifte ; inline
] if ; inline
: (integer^) ( z w -- z^w )
1 swap [ 1 number= [ dupd * ] when >r sq r> ] each-bit nip ;
@ -47,8 +47,8 @@ M: integer ^ ( z w -- z^w )
over 0 number= over 0 number= and [
"0^0 is not defined" throw
] [
dup 0 < [ neg ^ recip ] [ (integer^) ] ifte
] ifte ;
dup 0 < [ neg ^ recip ] [ (integer^) ] if
] if ;
: (^mod) ( n z w -- z^w )
1 swap [
@ -61,4 +61,4 @@ M: integer ^ ( z w -- z^w )
[ >r neg r> ^mod ] keep mod-inv
] [
-rot (^mod)
] ifte ; foldable
] if ; foldable

4
library/math/random.factor
View File

@ -7,14 +7,14 @@ IN: math USING: kernel ;
2drop (random-int) 2dup swap mod (random-int-0)
] [
2nip
] ifte ; inline
] if ; inline
: random-int-0 ( max -- n )
1+ dup power-of-2? [
(random-int) * -31 shift
] [
(random-int) 2dup swap mod (random-int-0)
] ifte ; inline
] if ; inline
: random-int ( min max -- n )
dupd swap - random-int-0 + ; flushable

2
library/math/ratio.factor
View File

@ -17,7 +17,7 @@ IN: math-internals
[ >fraction ] 2apply swapd ; inline
M: ratio number= ( a/b c/d -- ? )
2>fraction number= [ number= ] [ 2drop f ] ifte ;
2>fraction number= [ number= ] [ 2drop f ] if ;
: scale ( a/b c/d -- a*d b*c )
2>fraction >r * swap r> * swap ; inline

4
library/sdl/sdl-utils.factor
View File

@ -58,7 +58,7 @@ SYMBOL: bpp
bitand 0 = not
] [
drop t
] ifte ;
] if ;
: with-surface ( quot -- )
#! Execute a quotation, locking the current surface if it
@ -68,7 +68,7 @@ SYMBOL: bpp
dup SDL_LockSurface drop slip dup SDL_UnlockSurface
] [
slip
] ifte SDL_Flip drop
] if SDL_Flip drop
] with-scope ; inline
: surface-rect ( x y surface -- rect )

24
library/syntax/parse-words.factor
View File

@ -19,27 +19,27 @@ SYMBOL: line-number
: use+ ( string -- ) "use" [ cons ] change ;
: parsing? ( word -- ? )
dup word? [ "parsing" word-prop ] [ drop f ] ifte ;
dup word? [ "parsing" word-prop ] [ drop f ] if ;
SYMBOL: file
: skip ( i seq quot -- n | quot: elt -- ? )
over >r find* drop dup -1 =
[ drop r> length ] [ r> drop ] ifte ; inline
[ drop r> length ] [ r> drop ] if ; inline
: skip-blank ( -- )
"col" [ "line" get [ blank? not ] skip ] change ;
: skip-word ( n line -- n )
2dup nth CHAR: " = [ drop 1+ ] [ [ blank? ] skip ] ifte ;
2dup nth CHAR: " = [ drop 1+ ] [ [ blank? ] skip ] if ;
: (scan) ( n line -- start end )
dupd 2dup length < [ skip-word ] [ drop ] ifte ;
dupd 2dup length < [ skip-word ] [ drop ] if ;
: scan ( -- token )
skip-blank
"col" [ "line" get (scan) dup ] change
2dup = [ 2drop f ] [ "line" get subseq ] ifte ;
2dup = [ 2drop f ] [ "line" get subseq ] if ;
: save-location ( word -- )
#! Remember where this word was defined.
@ -60,7 +60,7 @@ global [ string-mode off ] bind
: scan-word ( -- obj )
scan dup [
dup ";" = not string-mode get and [
dup "use" get search [ ] [ string>number ] ?ifte
dup "use" get search [ ] [ string>number ] ?if
] unless
] when ;
@ -101,14 +101,14 @@ global [ string-mode off ] bind
swap 1+ dup 4 + [ rot subseq hex> ] keep
] [
over 1+ >r nth escape r>
] ifte ;
] if ;
: next-char ( n str -- ch n )
2dup nth CHAR: \\ = [
>r 1+ r> next-escape
] [
over 1+ >r nth r>
] ifte ;
] if ;
: doc-comment-here? ( parsed -- ? )
not "in-definition" get and ;
@ -119,10 +119,10 @@ global [ string-mode off ] bind
drop
] [
word swap "stack-effect" set-word-prop
] ifte
] if
] [
drop
] ifte ;
] if ;
: documentation+ ( word str -- )
over "documentation" word-prop [
@ -135,14 +135,14 @@ global [ string-mode off ] bind
word swap documentation+
] [
drop
] ifte ;
] if ;
: (parse-string) ( n str -- n )
2dup nth CHAR: " = [
drop 1+
] [
[ next-char swap , ] keep (parse-string)
] ifte ;
] if ;
: parse-string ( -- str )
#! Read a string from the input stream, until it is

2
library/syntax/parser.factor
View File

@ -5,7 +5,7 @@ USING: kernel lists namespaces sequences words ;
: parse-loop ( -- )
scan-word [
dup parsing? [ execute ] [ swons ] ifte parse-loop
dup parsing? [ execute ] [ swons ] if parse-loop
] when* ;
: (parse) ( str -- )

30
library/syntax/prettyprint.factor
View File

@ -60,7 +60,7 @@ C: section ( length -- section )
line-count inc
line-limit? [ "..." write end-printing get continue ] when
"\n" write do-indent
] ifte ;
] if ;
TUPLE: text string style ;
@ -83,14 +83,14 @@ C: block ( -- block )
: pprinter-block pprinter-stack peek ;
: block-empty? ( section -- ? )
dup block? [ block-sections empty? ] [ drop f ] ifte ;
dup block? [ block-sections empty? ] [ drop f ] if ;
: add-section ( section stream -- )
over block-empty? [
2drop
] [
pprinter-block block-sections push
] ifte ;
] if ;
: text ( string style -- ) <text> pprinter get add-section ;
@ -103,11 +103,11 @@ C: block ( -- block )
dup section-start fresh-line dup pprint-section*
dup indent>
dup section-nl-after?
[ section-end fresh-line ] [ drop ] ifte ;
[ section-end fresh-line ] [ drop ] if ;
: pprint-section ( section -- )
dup section-fits?
[ pprint-section* ] [ inset-section ] ifte ;
[ pprint-section* ] [ inset-section ] if ;
TUPLE: newline ;
@ -122,7 +122,7 @@ M: newline pprint-section* ( newline -- )
drop
] [
section-start last-newline get = [ " " write ] unless
] ifte ;
] if ;
M: block pprint-section* ( block -- )
f swap block-sections [
@ -207,8 +207,8 @@ M: real pprint* ( obj -- ) number>string f text ;
dup quotable? [
,
] [
dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?ifte %
] ifte ;
dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if %
] if ;
: do-string-limit ( string -- string )
string-limit get [
@ -249,13 +249,13 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
over recursion-check [ cons ] change
call
recursion-check [ cdr ] change
] ifte
] ifte ; inline
] if
] if ; inline
: length-limit? ( seq -- seq ? )
length-limit get dup
[ swap 2dup length < [ head t ] [ nip f ] ifte ]
[ drop f ] ifte ;
[ swap 2dup length < [ head t ] [ nip f ] if ]
[ drop f ] if ;
: pprint-element ( object -- )
dup parsing? [ \ POSTPONE: pprint-word ] when pprint* ;
@ -273,7 +273,7 @@ M: complex pprint* ( num -- )
M: cons pprint* ( list -- )
[
dup list? [ \ [ \ ] ] [ uncons 2array \ [[ \ ]] ] ifte
dup list? [ \ [ \ ] ] [ uncons 2array \ [[ \ ]] ] if
pprint-sequence
] check-recursion ;
@ -299,14 +299,14 @@ M: alien pprint* ( alien -- )
drop "( alien expired )"
] [
\ ALIEN: pprint-word alien-address number>string
] ifte f text ;
] if f text ;
M: wrapper pprint* ( wrapper -- )
dup wrapped word? [
\ \ pprint-word wrapped pprint-word
] [
wrapped 1array \ W[ \ ]W pprint-sequence
] ifte ;
] if ;
: with-pprint ( quot -- )
[

6
library/syntax/see.factor
View File

@ -5,7 +5,7 @@ USING: generic hashtables io kernel lists math namespaces
sequences styles words ;
: declaration. ( word prop -- )
tuck word-name word-prop [ pprint-word ] [ drop ] ifte ;
tuck word-name word-prop [ pprint-word ] [ drop ] if ;
: declarations. ( word -- )
[
@ -34,7 +34,7 @@ sequences styles words ;
dup "stack-effect" word-prop [ ] [
"infer-effect" word-prop
dup [ effect>string ] when
] ?ifte ;
] ?if ;
: stack-effect. ( string -- )
[ "(" swap ")" append3 comment. ] when* ;
@ -87,7 +87,7 @@ GENERIC: class. ( word -- )
] each-with
] [
drop
] ifte ;
] if ;
M: union class.
\ UNION: pprint-word

4
library/test/benchmark/ack.factor
View File

@ -13,7 +13,7 @@ USE: test
drop 1- 1 ack
] [
dupd 1- ack >r 1- r> ack
] ifte
] ifte ; compiled
] if
] if ; compiled
[ 4093 ] [ 3 9 ack ] unit-test

2
library/test/benchmark/fac.factor
View File

@ -6,7 +6,7 @@ USING: compiler kernel math sequences test ;
drop
] [
[ * ] keep 1- (fac)
] ifte ;
] if ;
: fac ( n -- n! )
1 swap (fac) ;

8
library/test/benchmark/fib.factor
View File

@ -14,13 +14,13 @@ USE: namespaces
drop 1
] [
1 fixnum- dup fixnum-fib swap 1 fixnum- fixnum-fib fixnum+
] ifte ;
] if ;
compiled
[ 9227465 ] [ 34 fixnum-fib ] unit-test
: fib ( n -- nth fibonacci number )
dup 1 <= [ drop 1 ] [ 1- dup fib swap 1- fib + ] ifte ;
dup 1 <= [ drop 1 ] [ 1- dup fib swap 1- fib + ] if ;
compiled
[ 9227465 ] [ 34 fib ] unit-test
@ -37,7 +37,7 @@ TUPLE: box i ;
box-i 1- <box>
tuple-fib
swap box-i swap box-i + <box>
] ifte ; compiled
] if ; compiled
[ << box f 9227465 >> ] [ << box f 34 >> tuple-fib ] unit-test
@ -51,7 +51,7 @@ SYMBOL: n
n get 1 - namespace-fib
n get 2 - namespace-fib
+
] ifte
] if
] with-scope ; compiled
[ 9227465 ] [ 34 namespace-fib ] unit-test

2
library/test/benchmark/strings.factor
View File

@ -10,7 +10,7 @@ USING: compiler kernel math namespaces sequences strings test ;
string-step
] [
2drop
] ifte ; compiled
] if ; compiled
: string-benchmark ( n -- )
"abcdef" 10 [ 2dup string-step ] times 2drop ; compiled

Some files were not shown because too many files have changed in this diff Show More