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

code cleanups

cvs
Slava Pestov 2004-12-11 02:39:27 +00:00
parent e965801789
commit 50130a62a1
48 changed files with 532 additions and 716 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
examples/dejong.factor
View File

@ -18,7 +18,7 @@ USE: sdl-gfx
USE: sdl-video USE: sdl-video
USE: namespaces USE: namespaces
USE: math USE: math
USE: stack USE: kernel
SYMBOL: a SYMBOL: a
SYMBOL: b SYMBOL: b

11
examples/factoroids.factor
View File

@ -9,7 +9,6 @@
IN: factoroids IN: factoroids
USE: combinators
USE: errors USE: errors
USE: hashtables USE: hashtables
USE: kernel USE: kernel
@ -24,7 +23,6 @@ USE: sdl-event
USE: sdl-gfx USE: sdl-gfx
USE: sdl-keysym USE: sdl-keysym
USE: sdl-video USE: sdl-video
USE: stack
! Game objects ! Game objects
GENERIC: draw ( actor -- ) GENERIC: draw ( actor -- )
@ -66,7 +64,7 @@ SYMBOL: enemy-shots
: move ( -- ) : move ( -- )
#! Add velocity vector to current actor's position vector. #! Add velocity vector to current actor's position vector.
velocity get position +@ ; velocity get position [ + ] change ;
: active? ( actor -- ? ) : active? ( actor -- ? )
#! Push f if the actor should be removed. #! Push f if the actor should be removed.
@ -222,6 +220,11 @@ M: enemy draw ( actor -- )
: attack-chance 30 ; : attack-chance 30 ;
: chance ( n -- boolean )
#! Returns true with a 1/n probability, false with a (n-1)/n
#! probability.
1 swap random-int 1 = ;
: attack ( actor -- ) : attack ( actor -- )
#! Fire a shot some of the time. #! Fire a shot some of the time.
attack-chance chance [ enemy-fire ] [ drop ] ifte ; attack-chance chance [ enemy-fire ] [ drop ] ifte ;
@ -230,7 +233,7 @@ SYMBOL: wiggle-x
: wiggle ( -- ) : wiggle ( -- )
#! Wiggle from left to right. #! Wiggle from left to right.
-3 3 random-int wiggle-x +@ -3 3 random-int wiggle-x [ + ] change
wiggle-x get sgn 1 rect> velocity set ; wiggle-x get sgn 1 rect> velocity set ;
M: enemy tick ( actor -- ) M: enemy tick ( actor -- )

7
examples/infix.factor
View File

@ -1,12 +1,15 @@
USE: combinators USE: kernel
USE: lists USE: lists
USE: math USE: math
USE: namespaces USE: namespaces
USE: stack
USE: test USE: test
USE: vectors USE: vectors
USE: words USE: words
: vector-peek ( vector -- obj )
#! Get value at end of vector without removing it.
dup vector-length pred swap vector-nth ;
SYMBOL: exprs SYMBOL: exprs
DEFER: infix DEFER: infix
: >e exprs get vector-push ; : >e exprs get vector-push ;

3
examples/irc.factor
View File

@ -1,10 +1,9 @@
! A simple IRC client written in Factor. ! A simple IRC client written in Factor.
USE: stack
USE: stdio USE: stdio
USE: namespaces USE: namespaces
USE: streams USE: streams
USE: combinators USE: kernel
USE: threads USE: threads
SYMBOL: irc-stream SYMBOL: irc-stream

3
examples/mandel.factor
View File

@ -10,18 +10,15 @@
IN: mandel IN: mandel
USE: alien USE: alien
USE: combinators
USE: errors USE: errors
USE: kernel USE: kernel
USE: lists USE: lists
USE: logic
USE: math USE: math
USE: namespaces USE: namespaces
USE: sdl USE: sdl
USE: sdl-event USE: sdl-event
USE: sdl-gfx USE: sdl-gfx
USE: sdl-video USE: sdl-video
USE: stack
USE: vectors USE: vectors
USE: prettyprint USE: prettyprint
USE: stdio USE: stdio

88
examples/more-random.factor Normal file
View File

@ -0,0 +1,88 @@
USE: random
USE: kernel
USE: lists
USE: math
USE: test
USE: namespaces
: random-element ( list -- random )
#! Returns a random element from the given list.
dup >r length pred 0 swap random-int r> nth ;
: random-subset ( list -- list )
#! Returns a random subset of the given list. Each item is
#! chosen with a 50%
#! probability.
[ drop random-boolean ] subset ;
: car+ ( list -- sum )
#! Adds the car of each element of the given list.
0 swap [ car + ] each ;
: random-probability ( list -- sum )
#! Adds the car of each element of the given list, and
#! returns a random number between 1 and this sum.
1 swap car+ random-int ;
: random-element-iter ( list index -- elem )
#! Used by random-element*. Do not call directly.
>r unswons unswons r> ( list elem probability index )
swap - ( list elem index )
dup 0 <= [
drop nip
] [
nip random-element-iter
] ifte ;
: random-element* ( list -- elem )
#! Returns a random element of the given list of comma
#! pairs. The car of each pair is a probability, the cdr is
#! the item itself. Only the cdr of the comma pair is
#! returned.
dup 1 swap car+ random-int random-element-iter ;
: random-subset* ( list -- list )
#! Returns a random subset of the given list of comma pairs.
#! The car of each pair is a probability, the cdr is the
#! item itself. Only the cdr of the comma pair is returned.
[
[ car+ ] keep ( probabilitySum list )
[
>r 1 over random-int r> ( probabilitySum probability elem )
uncons ( probabilitySum probability elema elemd )
-rot ( probabilitySum elemd probability elema )
> ( probabilitySum elemd boolean )
[ drop ] [ , ] ifte
] each drop
] make-list ;
: check-random-subset ( expected pairs -- )
random-subset* [ over contains? ] all? nip ;
[
[ t ]
[ [ 1 2 3 ] random-element number? ]
unit-test
[
[ 10 | t ]
[ 20 | f ]
[ 30 | "monkey" ]
[ 24 | 1/2 ]
[ 13 | { "Hello" "Banana" } ]
] "random-pairs" set
"random-pairs" get [ cdr ] map "random-values" set
[ f ]
[
"random-pairs" get
random-element* "random-values" get contains? not
] unit-test
[ t ] [
"random-values" get
"random-pairs" get
check-random-subset
] unit-test
] with-scope

2
examples/numbers-game.factor
View File

@ -1,13 +1,11 @@
! Numbers game example ! Numbers game example
IN: numbers-game IN: numbers-game
USE: combinators
USE: kernel USE: kernel
USE: math USE: math
USE: parser USE: parser
USE: random USE: random
USE: stdio USE: stdio
USE: stack
: read-number ( -- n ) read parse-number ; : read-number ( -- n ) read parse-number ;

2
examples/quadratic.factor
View File

@ -27,7 +27,7 @@
IN: quadratic IN: quadratic
USE: math USE: math
USE: stack USE: kernel
: quadratic-e ( b a -- -b/2a ) : quadratic-e ( b a -- -b/2a )
2 * / neg ; 2 * / neg ;

2
examples/timesheet.factor
View File

@ -1,14 +1,12 @@
! Contractor timesheet example ! Contractor timesheet example
IN: timesheet IN: timesheet
USE: combinators
USE: errors USE: errors
USE: format USE: format
USE: kernel USE: kernel
USE: lists USE: lists
USE: math USE: math
USE: parser USE: parser
USE: stack
USE: stdio USE: stdio
USE: strings USE: strings
USE: unparser USE: unparser

6
library/assoc.factor
View File

@ -76,9 +76,3 @@ USE: kernel
2drop 2drop
] ifte r> ] ifte r>
] each drop ; ] each drop ;
: unzip ( assoc -- keys values )
#! Split an association list into two lists of keys and
#! values.
[ ] [ ] rot [ uncons 2swons ] each
swap reverse swap reverse ;

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

@ -51,7 +51,6 @@ USE: stdio
"/library/hashtables.factor" "/library/hashtables.factor"
"/library/namespaces.factor" "/library/namespaces.factor"
"/library/generic.factor" "/library/generic.factor"
"/library/math/namespace-math.factor"
"/library/list-namespaces.factor" "/library/list-namespaces.factor"
"/library/sbuf.factor" "/library/sbuf.factor"
"/library/continuations.factor" "/library/continuations.factor"

1
library/bootstrap/boot.factor
View File

@ -53,7 +53,6 @@ primitives,
"/library/hashtables.factor" "/library/hashtables.factor"
"/library/namespaces.factor" "/library/namespaces.factor"
"/library/generic.factor" "/library/generic.factor"
"/library/math/namespace-math.factor"
"/library/list-namespaces.factor" "/library/list-namespaces.factor"
"/library/sbuf.factor" "/library/sbuf.factor"
"/library/continuations.factor" "/library/continuations.factor"

1
library/bootstrap/cross-compiler.factor
View File

@ -121,7 +121,6 @@ DEFER: pending-io-error
DEFER: next-io-task DEFER: next-io-task
IN: math IN: math
DEFER: >fraction
DEFER: fraction> DEFER: fraction>
IN: math-internals IN: math-internals

22
library/bootstrap/image.factor
View File

@ -42,6 +42,7 @@ IN: image
USE: errors USE: errors
USE: hashtables USE: hashtables
USE: kernel USE: kernel
USE: kernel-internals
USE: lists USE: lists
USE: math USE: math
USE: namespaces USE: namespaces
@ -77,29 +78,12 @@ SYMBOL: boot-quot
: cell "64-bits" get 8 4 ? ; : cell "64-bits" get 8 4 ? ;
: char "64-bits" get 4 2 ? ; : char "64-bits" get 4 2 ? ;
: tag-mask BIN: 111 ; : tag-mask BIN: 111 ; inline
: tag-bits 3 ; : tag-bits 3 ; inline
: untag ( cell tag -- ) tag-mask bitnot bitand ; : untag ( cell tag -- ) tag-mask bitnot bitand ;
: tag ( cell -- tag ) tag-mask bitand ; : tag ( cell -- tag ) tag-mask bitand ;
: fixnum-tag BIN: 000 ;
: word-tag BIN: 001 ;
: cons-tag BIN: 010 ;
: object-tag BIN: 011 ;
: ratio-tag BIN: 100 ;
: complex-tag BIN: 101 ;
: header-tag BIN: 110 ;
: gc-fwd-ptr BIN: 111 ; ( we don't output these )
: f-type 6 ;
: t-type 7 ;
: array-type 8 ;
: bignum-type 9 ;
: float-type 10 ;
: vector-type 11 ;
: string-type 12 ;
: immediate ( x tag -- tagged ) swap tag-bits shift bitor ; : immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
: >header ( id -- tagged ) header-tag immediate ; : >header ( id -- tagged ) header-tag immediate ;

2
library/compiler/linearizer.factor
View File

@ -148,5 +148,3 @@ SYMBOL: #return-to ( push addr on C stack )
] "linearizer" set-word-property ] "linearizer" set-word-property
#values [ drop ] "linearizer" set-word-property #values [ drop ] "linearizer" set-word-property
#nop [ drop ] "linearizer" set-word-property

2
library/compiler/xt.factor
View File

@ -53,7 +53,7 @@ USE: words
SYMBOL: compiled-xts SYMBOL: compiled-xts
: save-xt ( word -- ) : save-xt ( word -- )
compiled-offset swap compiled-xts acons@ ; compiled-offset swap compiled-xts [ acons ] change ;
: commit-xt ( xt word -- ) : commit-xt ( xt word -- )
dup t "compiled" set-word-property set-word-xt ; dup t "compiled" set-word-property set-word-xt ;

6
library/cons.factor
View File

@ -50,9 +50,3 @@ USE: kernel
: 2cdr ( cons cons -- car car ) : 2cdr ( cons cons -- car car )
swap cdr swap cdr ; swap cdr swap cdr ;
: 2cons ( cdr1 cdr2 car1 car2 -- cons1 cons2 )
rot swons >r cons r> ;
: 2swons ( cdr1 cdr2 car1 car2 -- cons1 cons2 )
rot cons >r swons r> ;

4
library/inference/branches.factor
View File

@ -151,9 +151,7 @@ USE: hashtables
infer-branches ; infer-branches ;
: vtable>list ( [ vtable | rstate ] -- list ) : vtable>list ( [ vtable | rstate ] -- list )
#! generic and 2generic use vectors of words, we need lists unswons vector>list [ over cons ] map nip ;
#! of quotations.
unswons vector>list [ unit over cons ] map nip ;
: infer-generic ( -- ) : infer-generic ( -- )
#! Infer effects for all branches, unify. #! Infer effects for all branches, unify.

2
library/inference/dataflow.factor
View File

@ -61,8 +61,6 @@ SYMBOL: #swap
SYMBOL: #over SYMBOL: #over
SYMBOL: #pick SYMBOL: #pick
SYMBOL: #nop
SYMBOL: #>r SYMBOL: #>r
SYMBOL: #r> SYMBOL: #r>

2
library/inference/inference.factor
View File

@ -80,7 +80,7 @@ SYMBOL: save-effect
: ensure-d ( count -- ) : ensure-d ( count -- )
#! Ensure count of unknown results are on the stack. #! Ensure count of unknown results are on the stack.
meta-d [ ensure ] change d-in +@ ; meta-d [ ensure ] change d-in [ + ] change ;
: consume-d ( count -- ) : consume-d ( count -- )
#! Remove count of elements. #! Remove count of elements.

3
library/inference/words.factor
View File

@ -72,8 +72,7 @@ USE: prettyprint
>r >r
<recursive-state> [ recursive-label set ] extend dupd cons <recursive-state> [ recursive-label set ] extend dupd cons
recursive-state cons@ recursive-state cons@
r> call r> call ;
( recursive-state uncons@ drop ) ;
: (with-block) ( label quot -- ) : (with-block) ( label quot -- )
#! Call a quotation in a new namespace, and transfer #! Call a quotation in a new namespace, and transfer

16
library/io/ansi.factor
View File

@ -38,14 +38,14 @@ USE: generic
! Some words for outputting ANSI colors. ! Some words for outputting ANSI colors.
: black 0 ; inline ! black 0
: red 1 ; inline ! red 1
: green 2 ; inline ! green 2
: yellow 3 ; inline ! yellow 3
: blue 4 ; inline ! blue 4
: magenta 5 ; inline ! magenta 5
: cyan 6 ; inline ! cyan 6
: white 7 ; inline ! white 7
: clear ( -- code ) : clear ( -- code )
#! Clear screen #! Clear screen

78
library/kernel.factor
View File

@ -47,33 +47,31 @@ USE: vectors
! 'generic words' system will be built later. ! 'generic words' system will be built later.
: generic ( obj vtable -- ) : generic ( obj vtable -- )
>r dup type r> vector-nth execute ; >r dup type r> vector-nth call ;
: 2generic ( n n vtable -- ) : 2generic ( n n vtable -- )
>r 2dup arithmetic-type r> vector-nth execute ; >r 2dup arithmetic-type r> vector-nth call ;
: default-hashcode drop 0 ;
: hashcode ( obj -- hash ) : hashcode ( obj -- hash )
#! If two objects are =, they must have equal hashcodes. #! If two objects are =, they must have equal hashcodes.
{ {
nop ! 0 [ ] ! 0
word-hashcode ! 1 [ word-hashcode ] ! 1
cons-hashcode ! 2 [ cons-hashcode ] ! 2
default-hashcode ! 3 [ drop 0 ] ! 3
>fixnum ! 4 [ >fixnum ] ! 4
>fixnum ! 5 [ >fixnum ] ! 5
default-hashcode ! 6 [ drop 0 ] ! 6
default-hashcode ! 7 [ drop 0 ] ! 7
default-hashcode ! 8 [ drop 0 ] ! 8
>fixnum ! 9 [ >fixnum ] ! 9
>fixnum ! 10 [ >fixnum ] ! 10
vector-hashcode ! 11 [ vector-hashcode ] ! 11
str-hashcode ! 12 [ str-hashcode ] ! 12
sbuf-hashcode ! 13 [ sbuf-hashcode ] ! 13
default-hashcode ! 14 [ drop 0 ] ! 14
default-hashcode ! 15 [ drop 0 ] ! 15
default-hashcode ! 16 [ drop 0 ] ! 16
} generic ; } generic ;
IN: math DEFER: number= ( defined later... ) IN: math DEFER: number= ( defined later... )
@ -81,29 +79,25 @@ IN: kernel
: = ( obj obj -- ? ) : = ( obj obj -- ? )
#! Push t if a is isomorphic to b. #! Push t if a is isomorphic to b.
{ {
number= ! 0 [ number= ] ! 0
eq? ! 1 [ eq? ] ! 1
cons= ! 2 [ cons= ] ! 2
eq? ! 3 [ eq? ] ! 3
number= ! 4 [ number= ] ! 4
number= ! 5 [ number= ] ! 5
eq? ! 6 [ eq? ] ! 6
eq? ! 7 [ eq? ] ! 7
eq? ! 8 [ eq? ] ! 8
number= ! 9 [ number= ] ! 9
number= ! 10 [ number= ] ! 10
vector= ! 11 [ vector= ] ! 11
str= ! 12 [ str= ] ! 12
sbuf= ! 13 [ sbuf= ] ! 13
eq? ! 14 [ eq? ] ! 14
eq? ! 15 [ eq? ] ! 15
eq? ! 16 [ eq? ] ! 16
} generic ; } generic ;
: 2= ( a b c d -- ? )
#! Test if a = c, b = d.
rot = [ = ] [ 2drop f ] ifte ;
: set-boot ( quot -- ) : set-boot ( quot -- )
#! Set the boot quotation. #! Set the boot quotation.
8 setenv ; 8 setenv ;

15
library/list-namespaces.factor
View File

@ -28,26 +28,11 @@
IN: lists IN: lists
USE: kernel USE: kernel
USE: namespaces USE: namespaces
USE: math
: cons@ ( x var -- ) : cons@ ( x var -- )
#! Prepend x to the list stored in var. #! Prepend x to the list stored in var.
[ cons ] change ; [ cons ] change ;
: acons@ ( value key var -- )
#! Prepend [ key | value ] to the alist stored in var.
[ acons ] change ;
: uncons@ ( var -- car )
#! Push the car of the list in var, and set the var to the
#! cdr.
[ uncons ] change ;
: remove@ ( obj var -- )
#! Remove all occurrences of the object from the list
#! stored in the variable.
[ remove ] change ;
: unique@ ( elem var -- ) : unique@ ( elem var -- )
#! Prepend an element to the proper list stored in a #! Prepend an element to the proper list stored in a
#! variable if it is not already contained in the list. #! variable if it is not already contained in the list.

11
library/math/arithmetic.factor
View File

@ -32,17 +32,6 @@ USE: kernel
: rational? dup integer? swap ratio? or ; : rational? dup integer? swap ratio? or ;
: real? dup number? swap complex? not and ; : real? dup number? swap complex? not and ;
: odd? 2 mod 1 = ;
: even? 2 mod 0 = ;
: f>0 ( obj -- obj )
#! If f at the top of the stack, turn it into 0.
f 0 replace ;
: 0>f ( obj -- obj )
#! If 0 at the top of the stack, turn it into f.
0 f replace ;
: max ( x y -- z ) : max ( x y -- z )
2dup > [ drop ] [ nip ] ifte ; 2dup > [ drop ] [ nip ] ifte ;

616
library/math/generic.factor
View File

@ -42,7 +42,6 @@ DEFER: number=
[ swap real swap real ] 2keep [ swap real swap real ] 2keep
swap imaginary swap imaginary ; swap imaginary swap imaginary ;
: >fraction ( a/b -- a b ) dup numerator swap denominator ;
: 2>fraction ( a/b c/d -- a c b d ) : 2>fraction ( a/b c/d -- a c b d )
[ swap numerator swap numerator ] 2keep [ swap numerator swap numerator ] 2keep
swap denominator swap denominator ; swap denominator swap denominator ;
@ -91,386 +90,383 @@ IN: math-internals
: complex/f ( x y -- x/y ) : complex/f ( x y -- x/y )
(complex/) tuck /f >r /f r> rect> ; (complex/) tuck /f >r /f r> rect> ;
: (not-=) ( x y -- f )
2drop f ;
IN: math IN: math
USE: math-internals USE: math-internals
: number= ( x y -- ? ) : number= ( x y -- ? )
{ {
fixnum= [ fixnum= ]
(not-=) [ 2drop f ]
(not-=) [ 2drop f ]
(not-=) [ 2drop f ]
ratio= [ ratio= ]
complex= [ complex= ]
(not-=) [ 2drop f ]
(not-=) [ 2drop f ]
(not-=) [ 2drop f ]
bignum= [ bignum= ]
float= [ float= ]
(not-=) [ 2drop f ]
(not-=) [ 2drop f ]
(not-=) [ 2drop f ]
(not-=) [ 2drop f ]
(not-=) [ 2drop f ]
(not-=) [ 2drop f ]
} 2generic ; } 2generic ;
: + ( x y -- x+y ) : + ( x y -- x+y )
{ {
fixnum+ [ fixnum+ ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio+ [ ratio+ ]
complex+ [ complex+ ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum+ [ bignum+ ]
float+ [ float+ ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: - ( x y -- x-y ) : - ( x y -- x-y )
{ {
fixnum- [ fixnum- ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio- [ ratio- ]
complex- [ complex- ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum- [ bignum- ]
float- [ float- ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: * ( x y -- x*y ) : * ( x y -- x*y )
{ {
fixnum* [ fixnum* ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio* [ ratio* ]
complex* [ complex* ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum* [ bignum* ]
float* [ float* ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: / ( x y -- x/y ) : / ( x y -- x/y )
{ {
ratio [ ratio ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio/ [ ratio/ ]
complex/ [ complex/ ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio [ ratio ]
float/f [ float/f ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: /i ( x y -- x/y ) : /i ( x y -- x/y )
{ {
fixnum/i [ fixnum/i ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum/i [ bignum/i ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: /f ( x y -- x/y ) : /f ( x y -- x/y )
{ {
fixnum/f [ fixnum/f ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio/f [ ratio/f ]
complex/f [ complex/f ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum/f [ bignum/f ]
float/f [ float/f ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: mod ( x y -- x%y ) : mod ( x y -- x%y )
{ {
fixnum-mod [ fixnum-mod ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum-mod [ bignum-mod ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: /mod ( x y -- x/y x%y ) : /mod ( x y -- x/y x%y )
{ {
fixnum/mod [ fixnum/mod ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum/mod [ bignum/mod ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: bitand ( x y -- x&y ) : bitand ( x y -- x&y )
{ {
fixnum-bitand [ fixnum-bitand ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum-bitand [ bignum-bitand ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: bitor ( x y -- x|y ) : bitor ( x y -- x|y )
{ {
fixnum-bitor [ fixnum-bitor ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum-bitor [ bignum-bitor ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: bitxor ( x y -- x^y ) : bitxor ( x y -- x^y )
{ {
fixnum-bitxor [ fixnum-bitxor ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum-bitxor [ bignum-bitxor ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: bitnot ( x -- ~x ) : bitnot ( x -- ~x )
{ {
fixnum-bitnot [ fixnum-bitnot ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum-bitnot [ bignum-bitnot ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} generic ; } generic ;
: shift ( x n -- x<<n ) : shift ( x n -- x<<n )
{ {
fixnum-shift [ fixnum-shift ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum-shift [ bignum-shift ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: < ( x y -- ? ) : < ( x y -- ? )
{ {
fixnum< [ fixnum< ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio< [ ratio< ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum< [ bignum< ]
float< [ float< ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: <= ( x y -- ? ) : <= ( x y -- ? )
{ {
fixnum<= [ fixnum<= ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio<= [ ratio<= ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum<= [ bignum<= ]
float<= [ float<= ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: > ( x y -- ? ) : > ( x y -- ? )
{ {
fixnum> [ fixnum> ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio> [ ratio> ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum> [ bignum> ]
float> [ float> ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;
: >= ( x y -- ? ) : >= ( x y -- ? )
{ {
fixnum>= [ fixnum>= ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
ratio>= [ ratio>= ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
bignum>= [ bignum>= ]
float>= [ float>= ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
undefined-method [ undefined-method ]
} 2generic ; } 2generic ;

39
library/math/namespace-math.factor
View File

@ -1,39 +0,0 @@
! :folding=indent:collapseFolds=0:
! $Id$
!
! Copyright (C) 2003, 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math
USE: kernel
USE: namespaces
: +@ ( num var -- ) tuck get + put ;
: -@ ( num var -- ) tuck get swap - put ;
: *@ ( num var -- ) tuck get * put ;
: /@ ( num var -- ) tuck get swap / put ;
: mod@ ( num var -- ) tuck get swap mod put ;
: rem@ ( num var -- ) tuck get swap rem put ;
: pred@ ( var -- ) dup get pred put ;
: succ@ ( var -- ) dup get succ put ;

1
library/namespaces.factor
View File

@ -149,4 +149,3 @@ USE: vectors
: on ( var -- ) t put ; : on ( var -- ) t put ;
: off ( var -- ) f put ; : off ( var -- ) f put ;
: toggle ( var -- ) dup get not put ;

62
library/random.factor
View File

@ -53,67 +53,5 @@ USE: math
: random-boolean ( -- ? ) : random-boolean ( -- ? )
0 1 random-int 0 = ; 0 1 random-int 0 = ;
! TODO: : random-float ... ;
: random-digit ( -- digit ) : random-digit ( -- digit )
0 9 random-int ; 0 9 random-int ;
: random-symmetric-int ( max -- random )
#! Return a random integer between -max and max.
dup neg swap random-int ;
: chance ( n -- boolean )
#! Returns true with a 1/n probability, false with a (n-1)/n
#! probability.
1 swap random-int 1 = ;
: random-element ( list -- random )
#! Returns a random element from the given list.
dup >r length pred 0 swap random-int r> nth ;
: random-subset ( list -- list )
#! Returns a random subset of the given list. Each item is
#! chosen with a 50%
#! probability.
[ drop random-boolean ] subset ;
: car+ ( list -- sum )
#! Adds the car of each element of the given list.
0 swap [ car + ] each ;
: random-probability ( list -- sum )
#! Adds the car of each element of the given list, and
#! returns a random number between 1 and this sum.
1 swap car+ random-int ;
: random-element-iter ( list index -- elem )
#! Used by random-element*. Do not call directly.
>r unswons unswons r> ( list elem probability index )
swap - ( list elem index )
dup 0 <= [
drop nip
] [
nip random-element-iter
] ifte ;
: random-element* ( list -- elem )
#! Returns a random element of the given list of comma
#! pairs. The car of each pair is a probability, the cdr is
#! the item itself. Only the cdr of the comma pair is
#! returned.
dup 1 swap car+ random-int random-element-iter ;
: random-subset* ( list -- list )
#! Returns a random subset of the given list of comma pairs.
#! The car of each pair is a probability, the cdr is the
#! item itself. Only the cdr of the comma pair is returned.
[
[ car+ ] keep ( probabilitySum list )
[
>r 1 over random-int r> ( probabilitySum probability elem )
uncons ( probabilitySum probability elema elemd )
-rot ( probabilitySum elemd probability elema )
> ( probabilitySum elemd boolean )
[ drop ] [ , ] ifte
] each drop
] make-list ;

14
library/sdl/hsv.factor
View File

@ -12,7 +12,7 @@ USE: lists
USE: math USE: math
USE: namespaces USE: namespaces
: f_ ( h s v i -- f ) >r transp >r 2dup r> 6 * r> - ; : f_ ( h s v i -- f ) >r swap rot >r 2dup r> 6 * r> - ;
: p ( v s x -- v p x ) >r dupd neg succ * r> ; : p ( v s x -- v p x ) >r dupd neg succ * r> ;
: q ( v s f -- q ) * neg succ * ; : q ( v s f -- q ) * neg succ * ;
: t_ ( v s f -- t_ ) neg succ * neg succ * ; : t_ ( v s f -- t_ ) neg succ * neg succ * ;
@ -25,10 +25,10 @@ USE: namespaces
: hsv>rgb ( h s v -- r g b ) : hsv>rgb ( h s v -- r g b )
pick 6 * >fixnum [ pick 6 * >fixnum [
[ f_ t_ p swap ( v p t ) ] [ f_ t_ p swap ( v p t ) ]
[ f_ q p -rot ( q v p ) ] [ f_ q p -rot ( q v p ) ]
[ f_ t_ p swapd ( p v t ) ] [ f_ t_ p swapd ( p v t ) ]
[ f_ q p rot ( p q v ) ] [ f_ q p rot ( p q v ) ]
[ f_ t_ p transp ( t p v ) ] [ f_ t_ p swap rot ( t p v ) ]
[ f_ q p ( v p q ) ] [ f_ q p ( v p q ) ]
] mod-cond ; ] mod-cond ;

2
library/stack.factor
View File

@ -28,7 +28,6 @@
IN: kernel IN: kernel
USE: vectors USE: vectors
: nop ( -- ) ;
: 2drop ( x x -- ) drop drop ; inline : 2drop ( x x -- ) drop drop ; inline
: 3drop ( x x x -- ) drop drop drop ; inline : 3drop ( x x x -- ) drop drop drop ; inline
: 2dup ( x y -- x y x y ) over over ; inline : 2dup ( x y -- x y x y ) over over ; inline
@ -37,7 +36,6 @@ USE: vectors
: -rot ( x y z -- z x y ) swap >r swap r> ; inline : -rot ( x y z -- z x y ) swap >r swap r> ; inline
: dupd ( x y -- x x y ) >r dup r> ; inline : dupd ( x y -- x x y ) >r dup r> ; inline
: swapd ( x y z -- y x z ) >r swap r> ; inline : swapd ( x y z -- y x z ) >r swap r> ; inline
: transp ( x y z -- z y x ) swap rot ; inline
: nip ( x y -- y ) swap drop ; inline : nip ( x y -- y ) swap drop ; inline
: tuck ( x y -- y x y ) dup >r swap r> ; inline : tuck ( x y -- y x y ) dup >r swap r> ; inline

10
library/strings.factor
View File

@ -55,12 +55,6 @@ USE: math
: cat3 ( "a" "b" "c" -- "abc" ) : cat3 ( "a" "b" "c" -- "abc" )
[ ] cons cons cons cat ; [ ] cons cons cons cat ;
: cat4 ( "a" "b" "c" "d" -- "abcd" )
[ ] cons cons cons cons cat ;
: cat5 ( "a" "b" "c" "d" "e" -- "abcde" )
[ ] cons cons cons cons cons cat ;
: index-of ( string substring -- index ) : index-of ( string substring -- index )
0 -rot index-of* ; 0 -rot index-of* ;
@ -131,10 +125,6 @@ USE: math
#! list. #! list.
0 swap [ str-length max ] each ; 0 swap [ str-length max ] each ;
: ends-with-newline? ( string -- string )
#! Test if the string ends with a newline or not.
"\n" str-tail? ;
: str-each ( str [ code ] -- ) : str-each ( str [ code ] -- )
#! Execute the code, with each character of the string #! Execute the code, with each character of the string
#! pushed onto the stack. #! pushed onto the stack.

2
library/syntax/parse-stream.factor
View File

@ -42,7 +42,7 @@ USE: strings
: next-line ( -- str ) : next-line ( -- str )
"parse-stream" get freadln "parse-stream" get freadln
"line-number" succ@ ; "line-number" [ succ ] change ;
: (read-lines) ( quot -- ) : (read-lines) ( quot -- )
next-line dup [ next-line dup [

2
library/syntax/parser.factor
View File

@ -66,7 +66,7 @@ USE: unparser
"line" off "col" off ; "line" off "col" off ;
: ch ( -- ch ) "col" get "line" get str-nth ; : ch ( -- ch ) "col" get "line" get str-nth ;
: advance ( -- ) "col" succ@ ; : advance ( -- ) "col" [ succ ] change ;
: skip ( n line quot -- n ) : skip ( n line quot -- n )
#! Find the next character that satisfies the quotation, #! Find the next character that satisfies the quotation,

34
library/syntax/unparser.factor
View File

@ -133,21 +133,21 @@ DEFER: unparse
: unparse ( obj -- str ) : unparse ( obj -- str )
{ {
>dec [ >dec ]
unparse-word [ unparse-word ]
unparse-unknown [ unparse-unknown ]
unparse-unknown [ unparse-unknown ]
unparse-ratio [ unparse-ratio ]
unparse-complex [ unparse-complex ]
unparse-f [ unparse-f ]
unparse-t [ unparse-t ]
unparse-unknown [ unparse-unknown ]
>dec [ >dec ]
unparse-float [ unparse-float ]
unparse-unknown [ unparse-unknown ]
unparse-str [ unparse-str ]
unparse-unknown [ unparse-unknown ]
unparse-unknown [ unparse-unknown ]
unparse-unknown [ unparse-unknown ]
unparse-unknown [ unparse-unknown ]
} generic ; } generic ;

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

@ -9,8 +9,8 @@ USE: lists
: string-step ( n str -- ) : string-step ( n str -- )
2dup str-length > [ 2dup str-length > [
dup [ "123" , , "456" , , "789" , ] make-string dup [ "123" , , "456" , , "789" , ] make-string
dup dup str-length 2 /i 0 transp substring dup dup str-length 2 /i 0 swap rot substring
swap dup str-length 2 /i succ 1 transp substring cat2 swap dup str-length 2 /i succ 1 swap rot substring cat2
string-step string-step
] [ ] [
2drop 2drop

1
library/test/inference.factor
View File

@ -43,7 +43,6 @@ USE: math-internals
[ [ 2 | 4 ] ] [ [ 2dup ] infer ] unit-test [ [ 2 | 4 ] ] [ [ 2dup ] infer ] unit-test
[ [ 2 | 0 ] ] [ [ set-vector-length ] infer ] unit-test [ [ 2 | 0 ] ] [ [ set-vector-length ] infer ] unit-test
[ [ 1 | 0 ] ] [ [ vector-clear ] infer ] unit-test
[ [ 2 | 0 ] ] [ [ vector-push ] infer ] unit-test [ [ 2 | 0 ] ] [ [ vector-push ] infer ] unit-test
[ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer ] unit-test [ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer ] unit-test

7
library/test/lists/namespaces.factor
View File

@ -11,12 +11,9 @@ USE: test
"x" off 2 1 "x" acons@ 3 2 "x" acons@ "x" get "x" off 2 1 "x" acons@ 3 2 "x" acons@ "x" get
] unit-test ] unit-test
[ [ 2 | 3 ] ] [ "x" uncons@ ] unit-test
[ [ 1 | 2 ] ] [ "x" uncons@ ] unit-test
[ [ 5 4 3 1 ] ] [ [ [ 5 4 3 1 ] ] [
[ 5 4 3 2 1 ] "x" set [ 5 4 3 2 1 ] "x" set
2 "x" remove@ 2 "x" [ remove ] change
"x" get "x" get
] unit-test ] unit-test
@ -27,7 +24,7 @@ USE: test
f "x" unique@ f "x" unique@
5 "x" unique@ 5 "x" unique@
f "x" unique@ f "x" unique@
5 "x" remove@ 5 "x" [ remove ] change
"hello" "x" unique@ "hello" "x" unique@
"x" get "x" get
] unit-test ] unit-test

15
library/test/math/namespaces.factor
View File

@ -1,15 +0,0 @@
IN: scratchpad
USE: namespaces
USE: test
USE: math
5 "x" set
[ 6 ] [ 1 "x" +@ "x" get ] unit-test
[ 5 ] [ 1 "x" -@ "x" get ] unit-test
[ 10 ] [ 2 "x" *@ "x" get ] unit-test
[ 2 ] [ 5 "x" /@ "x" get ] unit-test
[ 1 ] [ "x" pred@ "x" get ] unit-test
[ 2 ] [ "x" succ@ "x" get ] unit-test
[ 7 ] [ -3 "x" set 10 "x" rem@ "x" get ] unit-test
[ -3 ] [ -3 "x" set 10 "x" mod@ "x" get ] unit-test

29
library/test/random.factor
View File

@ -6,36 +6,7 @@ USE: namespaces
USE: random USE: random
USE: test USE: test
[ t ]
[ [ 1 2 3 ] random-element number? ]
unit-test
[
[ 10 | t ]
[ 20 | f ]
[ 30 | "monkey" ]
[ 24 | 1/2 ]
[ 13 | { "Hello" "Banana" } ]
] "random-pairs" set
"random-pairs" get [ cdr ] map "random-values" set
[ f ]
[
"random-pairs" get
random-element* "random-values" get contains? not
] unit-test
: check-random-int ( min max -- ) : check-random-int ( min max -- )
2dup random-int -rot between? assert ; 2dup random-int -rot between? assert ;
[ ] [ 100 [ -12 674 check-random-int ] times ] unit-test [ ] [ 100 [ -12 674 check-random-int ] times ] unit-test
: check-random-subset ( expected pairs -- )
random-subset* [ over contains? ] all? nip ;
[ t ] [
"random-values" get
"random-pairs" get
check-random-subset
] unit-test

39
library/test/stack.factor
View File

@ -1,39 +0,0 @@
IN: scratchpad
USE: compiler
USE: stdio
USE: test
! Test the built-in stack words.
"Checking stack words." print
! OUTPUT INPUT WORD
[ ] [ 1 ] [ drop ] test-word
[ ] [ 1 2 ] [ 2drop ] test-word
[ 1 1 ] [ 1 ] [ dup ] test-word
[ 1 2 1 2 ] [ 1 2 ] [ 2dup ] test-word
[ 1 1 2 ] [ 1 2 ] [ dupd ] test-word
[ 1 2 1 2 3 4 ] [ 1 2 3 4 ] [ 2dupd ] test-word
[ 2 ] [ 1 2 ] [ nip ] test-word
[ 3 4 ] [ 1 2 3 4 ] [ 2nip ] test-word
[ ] [ ] [ nop ] test-word
[ 1 2 1 ] [ 1 2 ] [ over ] test-word
[ 1 2 3 4 1 2 ] [ 1 2 3 4 ] [ 2over ] test-word
[ 1 2 3 1 ] [ 1 2 3 ] [ pick ] test-word
[ 2 3 1 ] [ 1 2 3 ] [ rot ] test-word
[ 3 4 5 6 1 2 ] [ 1 2 3 4 5 6 ] [ 2rot ] test-word
[ 3 1 2 ] [ 1 2 3 ] [ -rot ] test-word
[ 5 6 1 2 3 4 ] [ 1 2 3 4 5 6 ] [ 2-rot ] test-word
[ 2 1 ] [ 1 2 ] [ swap ] test-word
[ 3 4 1 2 ] [ 1 2 3 4 ] [ 2swap ] test-word
[ 2 1 3 ] [ 1 2 3 ] [ swapd ] test-word
[ 3 4 1 2 5 6 ] [ 1 2 3 4 5 6 ] [ 2swapd ] test-word
[ 3 2 1 ] [ 1 2 3 ] [ transp ] test-word
[ 5 6 3 4 1 2 ] [ 1 2 3 4 5 6 ] [ 2transp ] test-word
[ 2 1 2 ] [ 1 2 ] [ tuck ] test-word
[ 3 4 1 2 3 4 ] [ 1 2 3 4 ] [ 2tuck ] test-word
[ ] [ 1 ] [ >r r> drop ] test-word
[ 1 2 ] [ 1 2 ] [ >r >r r> r> ] test-word
"Stack checks passed." print

10
library/test/strings.factor
View File

@ -14,8 +14,6 @@ USE: test
[ "abc" ] [ "ab" "c" cat2 ] unit-test [ "abc" ] [ "ab" "c" cat2 ] unit-test
[ "abc" ] [ "a" "b" "c" cat3 ] unit-test [ "abc" ] [ "a" "b" "c" cat3 ] unit-test
[ "abcd" ] [ "a" "b" "c" "d" cat4 ] unit-test
[ "abcde" ] [ "a" "b" "c" "d" "e" cat5 ] unit-test
[ 3 ] [ "hola" "a" index-of ] unit-test [ 3 ] [ "hola" "a" index-of ] unit-test
[ -1 ] [ "hola" "x" index-of ] unit-test [ -1 ] [ "hola" "x" index-of ] unit-test
@ -67,10 +65,10 @@ unit-test
max-str-length max-str-length
] unit-test ] unit-test
[ "Hello world" ] [ "Hello world\n" ends-with-newline? ] unit-test [ "Hello world" ] [ "Hello world\n" "\n" str-tail? ] unit-test
[ f ] [ "Hello world" ends-with-newline? ] unit-test [ f ] [ "Hello world" "\n" str-tail? ] unit-test
[ "" ] [ "\n" ends-with-newline? ] unit-test [ "" ] [ "\n" "\n" str-tail? ] unit-test
[ f ] [ "" ends-with-newline? ] unit-test [ f ] [ "" "\n" str-tail? ] unit-test
[ t ] [ CHAR: a letter? ] unit-test [ t ] [ CHAR: a letter? ] unit-test
[ f ] [ CHAR: A letter? ] unit-test [ f ] [ CHAR: A letter? ] unit-test

3
library/tools/inspector.factor
View File

@ -60,9 +60,6 @@ USE: vectors
3list 3list
default-style append ; default-style append ;
: var. ( [ name | value ] -- )
uncons unparse swap link-style write-attr ;
: var-name. ( max name -- ) : var-name. ( max name -- )
tuck unparse pad-string write dup link-style tuck unparse pad-string write dup link-style
swap unparse swap write-attr ; swap unparse swap write-attr ;

3
library/tools/interpreter.factor
View File

@ -46,7 +46,6 @@ SYMBOL: meta-r
: pop-r meta-r get vector-pop ; : pop-r meta-r get vector-pop ;
SYMBOL: meta-d SYMBOL: meta-d
: push-d meta-d get vector-push ; : push-d meta-d get vector-push ;
: peek-d meta-d get vector-peek ;
: pop-d meta-d get vector-pop ; : pop-d meta-d get vector-pop ;
SYMBOL: meta-n SYMBOL: meta-n
SYMBOL: meta-c SYMBOL: meta-c
@ -79,7 +78,7 @@ SYMBOL: meta-cf
pop-r meta-cf set ; pop-r meta-cf set ;
: next ( -- obj ) : next ( -- obj )
meta-cf get [ meta-cf uncons@ ] [ up next ] ifte ; meta-cf get [ meta-cf [ uncons ] change ] [ up next ] ifte ;
: host-word ( word -- ) : host-word ( word -- )
#! Swap in the meta-interpreter's stacks, execute the word, #! Swap in the meta-interpreter's stacks, execute the word,

49
library/types.factor
View File

@ -26,20 +26,43 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
USE: kernel USE: kernel
USE: math
IN: math : fixnum? ( obj -- ? ) type 0 eq? ; IN: kernel-internals
IN: words : word? ( obj -- ? ) type 1 eq? ;
IN: lists : cons? ( obj -- ? ) type 2 eq? ; : fixnum-tag BIN: 000 ; inline
IN: math : ratio? ( obj -- ? ) type 4 eq? ; : word-tag BIN: 001 ; inline
IN: math : complex? ( obj -- ? ) type 5 eq? ; : cons-tag BIN: 010 ; inline
IN: math : bignum? ( obj -- ? ) type 9 eq? ; : object-tag BIN: 011 ; inline
IN: math : float? ( obj -- ? ) type 10 eq? ; : ratio-tag BIN: 100 ; inline
IN: vectors : vector? ( obj -- ? ) type 11 eq? ; : complex-tag BIN: 101 ; inline
IN: strings : string? ( obj -- ? ) type 12 eq? ; : header-tag BIN: 110 ; inline
IN: strings : sbuf? ( obj -- ? ) type 13 eq? ;
IN: io-internals : port? ( obj -- ? ) type 14 eq? ; : f-type 6 ; inline
IN: alien : dll? ( obj -- ? ) type 15 eq? ; : t-type 7 ; inline
IN: alien : alien? ( obj -- ? ) type 16 eq? ; : array-type 8 ; inline
: bignum-type 9 ; inline
: float-type 10 ; inline
: vector-type 11 ; inline
: string-type 12 ; inline
: sbuf-type 13 ; inline
: port-type 14 ; inline
: dll-type 15 ; inline
: alien-type 16 ; inline
IN: math : fixnum? ( obj -- ? ) type fixnum-tag eq? ;
IN: words : word? ( obj -- ? ) type word-tag eq? ;
IN: lists : cons? ( obj -- ? ) type cons-tag eq? ;
IN: math : ratio? ( obj -- ? ) type ratio-tag eq? ;
IN: math : complex? ( obj -- ? ) type complex-tag eq? ;
IN: math : bignum? ( obj -- ? ) type bignum-type eq? ;
IN: math : float? ( obj -- ? ) type float-type eq? ;
IN: vectors : vector? ( obj -- ? ) type vector-type eq? ;
IN: strings : string? ( obj -- ? ) type string-type eq? ;
IN: strings : sbuf? ( obj -- ? ) type sbuf-type eq? ;
IN: io-internals : port? ( obj -- ? ) type port-type eq? ;
IN: alien : dll? ( obj -- ? ) type dll-type eq? ;
IN: alien : alien? ( obj -- ? ) type alien-type eq? ;
IN: kernel IN: kernel

2
library/vector-combinators.factor
View File

@ -68,7 +68,7 @@ USE: math
#! Make a new vector with each pair of elements from the #! Make a new vector with each pair of elements from the
#! first two in a pair. #! first two in a pair.
over vector-length [ over vector-length [
pick pick 2vector-nth cons pick pick >r over >r vector-nth r> r> vector-nth cons
] vector-project nip nip ; ] vector-project nip nip ;
: vector-2map ( v1 v2 quot -- v ) : vector-2map ( v1 v2 quot -- v )

11
library/vectors.factor
View File

@ -30,9 +30,6 @@ USE: kernel
USE: lists USE: lists
USE: math USE: math
: 2vector-nth ( n vec vec -- obj obj )
>r over >r vector-nth r> r> vector-nth ;
: empty-vector ( len -- vec ) : empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike #! Creates a vector with 'len' elements set to f. Unlike
#! <vector>, which gives an empty vector with a certain #! <vector>, which gives an empty vector with a certain
@ -42,18 +39,10 @@ USE: math
: vector-empty? ( obj -- ? ) : vector-empty? ( obj -- ? )
vector-length 0 = ; vector-length 0 = ;
: vector-clear ( vector -- )
#! Clears a vector.
0 swap set-vector-length ;
: vector-push ( obj vector -- ) : vector-push ( obj vector -- )
#! Push a value on the end of a vector. #! Push a value on the end of a vector.
dup vector-length swap set-vector-nth ; dup vector-length swap set-vector-nth ;
: vector-peek ( vector -- obj )
#! Get value at end of vector without removing it.
dup vector-length pred swap vector-nth ;
: vector-pop ( vector -- obj ) : vector-pop ( vector -- obj )
#! Get value at end of vector and remove it. #! Get value at end of vector and remove it.
dup vector-length pred ( vector top ) dup vector-length pred ( vector top )

1
library/words.factor
View File

@ -44,7 +44,6 @@ USE: strings
: ?word-primitive ( obj -- prim/0 ) : ?word-primitive ( obj -- prim/0 )
dup word? [ word-primitive ] [ drop 0 ] ifte ; dup word? [ word-primitive ] [ drop 0 ] ifte ;
: defined? ( obj -- ? ) ?word-primitive 0 = not ;
: compound? ( obj -- ? ) ?word-primitive 1 = ; : compound? ( obj -- ? ) ?word-primitive 1 = ;
: primitive? ( obj -- ? ) ?word-primitive 2 > ; : primitive? ( obj -- ? ) ?word-primitive 2 > ;
: symbol? ( obj -- ? ) ?word-primitive 2 = ; : symbol? ( obj -- ? ) ?word-primitive 2 = ;