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: namespaces
USE: math
USE: stack
USE: kernel
SYMBOL: a
SYMBOL: b

11
examples/factoroids.factor
View File

@ -9,7 +9,6 @@
IN: factoroids
USE: combinators
USE: errors
USE: hashtables
USE: kernel
@ -24,7 +23,6 @@ USE: sdl-event
USE: sdl-gfx
USE: sdl-keysym
USE: sdl-video
USE: stack
! Game objects
GENERIC: draw ( actor -- )
@ -66,7 +64,7 @@ SYMBOL: enemy-shots
: move ( -- )
#! Add velocity vector to current actor's position vector.
velocity get position +@ ;
velocity get position [ + ] change ;
: active? ( actor -- ? )
#! Push f if the actor should be removed.
@ -222,6 +220,11 @@ M: enemy draw ( actor -- )
: 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 -- )
#! Fire a shot some of the time.
attack-chance chance [ enemy-fire ] [ drop ] ifte ;
@ -230,7 +233,7 @@ SYMBOL: wiggle-x
: wiggle ( -- )
#! 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 ;
M: enemy tick ( actor -- )

7
examples/infix.factor
View File

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

3
examples/irc.factor
View File

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

3
examples/mandel.factor
View File

@ -10,18 +10,15 @@
IN: mandel
USE: alien
USE: combinators
USE: errors
USE: kernel
USE: lists
USE: logic
USE: math
USE: namespaces
USE: sdl
USE: sdl-event
USE: sdl-gfx
USE: sdl-video
USE: stack
USE: vectors
USE: prettyprint
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
IN: numbers-game
USE: combinators
USE: kernel
USE: math
USE: parser
USE: random
USE: stdio
USE: stack
: read-number ( -- n ) read parse-number ;

2
examples/quadratic.factor
View File

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

2
examples/timesheet.factor
View File

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

6
library/assoc.factor
View File

@ -76,9 +76,3 @@ USE: kernel
2drop
] ifte r>
] 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/namespaces.factor"
"/library/generic.factor"
"/library/math/namespace-math.factor"
"/library/list-namespaces.factor"
"/library/sbuf.factor"
"/library/continuations.factor"

1
library/bootstrap/boot.factor
View File

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

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

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

22
library/bootstrap/image.factor
View File

@ -42,6 +42,7 @@ IN: image
USE: errors
USE: hashtables
USE: kernel
USE: kernel-internals
USE: lists
USE: math
USE: namespaces
@ -77,29 +78,12 @@ SYMBOL: boot-quot
: cell "64-bits" get 8 4 ? ;
: char "64-bits" get 4 2 ? ;
: tag-mask BIN: 111 ;
: tag-bits 3 ;
: tag-mask BIN: 111 ; inline
: tag-bits 3 ; inline
: untag ( cell tag -- ) tag-mask bitnot 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 ;
: >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
#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
: save-xt ( word -- )
compiled-offset swap compiled-xts acons@ ;
compiled-offset swap compiled-xts [ acons ] change ;
: commit-xt ( xt word -- )
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 )
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 ;
: vtable>list ( [ vtable | rstate ] -- list )
#! generic and 2generic use vectors of words, we need lists
#! of quotations.
unswons vector>list [ unit over cons ] map nip ;
unswons vector>list [ over cons ] map nip ;
: infer-generic ( -- )
#! Infer effects for all branches, unify.

2
library/inference/dataflow.factor
View File

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

2
library/inference/inference.factor
View File

@ -80,7 +80,7 @@ SYMBOL: save-effect
: ensure-d ( count -- )
#! 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 -- )
#! Remove count of elements.

3
library/inference/words.factor
View File

@ -72,8 +72,7 @@ USE: prettyprint
>r
<recursive-state> [ recursive-label set ] extend dupd cons
recursive-state cons@
r> call
( recursive-state uncons@ drop ) ;
r> call ;
: (with-block) ( label quot -- )
#! 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.
: black 0 ; inline
: red 1 ; inline
: green 2 ; inline
: yellow 3 ; inline
: blue 4 ; inline
: magenta 5 ; inline
: cyan 6 ; inline
: white 7 ; inline
! black 0
! red 1
! green 2
! yellow 3
! blue 4
! magenta 5
! cyan 6
! white 7
: clear ( -- code )
#! Clear screen

78
library/kernel.factor
View File

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

15
library/list-namespaces.factor
View File

@ -28,26 +28,11 @@
IN: lists
USE: kernel
USE: namespaces
USE: math
: cons@ ( x var -- )
#! Prepend x to the list stored in var.
[ 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 -- )
#! Prepend an element to the proper list stored in a
#! 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 ;
: 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 )
2dup > [ drop ] [ nip ] ifte ;

616
library/math/generic.factor
View File

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

62
library/random.factor
View File

@ -53,67 +53,5 @@ USE: math
: random-boolean ( -- ? )
0 1 random-int 0 = ;
! TODO: : random-float ... ;
: random-digit ( -- digit )
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: 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> ;
: q ( v s f -- q ) * 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 )
pick 6 * >fixnum [
[ f_ t_ p swap ( v p t ) ]
[ f_ q p -rot ( q v p ) ]
[ f_ t_ p swapd ( p v t ) ]
[ f_ q p rot ( p q v ) ]
[ f_ t_ p transp ( t p v ) ]
[ f_ q p ( v p q ) ]
[ f_ t_ p swap ( v p t ) ]
[ f_ q p -rot ( q v p ) ]
[ f_ t_ p swapd ( p v t ) ]
[ f_ q p rot ( p q v ) ]
[ f_ t_ p swap rot ( t p v ) ]
[ f_ q p ( v p q ) ]
] mod-cond ;

2
library/stack.factor
View File

@ -28,7 +28,6 @@
IN: kernel
USE: vectors
: nop ( -- ) ;
: 2drop ( x x -- ) drop drop ; inline
: 3drop ( x x x -- ) drop drop drop ; 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
: dupd ( x y -- x x y ) >r dup 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
: 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" )
[ ] 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 )
0 -rot index-of* ;
@ -131,10 +125,6 @@ USE: math
#! list.
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 ] -- )
#! Execute the code, with each character of the string
#! pushed onto the stack.

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

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

2
library/syntax/parser.factor
View File

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

34
library/syntax/unparser.factor
View File

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

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

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

1
library/test/inference.factor
View File

@ -43,7 +43,6 @@ USE: math-internals
[ [ 2 | 4 ] ] [ [ 2dup ] 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
[ [ 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
] unit-test
[ [ 2 | 3 ] ] [ "x" uncons@ ] unit-test
[ [ 1 | 2 ] ] [ "x" uncons@ ] unit-test
[ [ 5 4 3 1 ] ] [
[ 5 4 3 2 1 ] "x" set
2 "x" remove@
2 "x" [ remove ] change
"x" get
] unit-test
@ -27,7 +24,7 @@ USE: test
f "x" unique@
5 "x" unique@
f "x" unique@
5 "x" remove@
5 "x" [ remove ] change
"hello" "x" unique@
"x" get
] 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: 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 -- )
2dup random-int -rot between? assert ;
[ ] [ 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" ] [ "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
[ -1 ] [ "hola" "x" index-of ] unit-test
@ -67,10 +65,10 @@ unit-test
max-str-length
] unit-test
[ "Hello world" ] [ "Hello world\n" ends-with-newline? ] unit-test
[ f ] [ "Hello world" ends-with-newline? ] unit-test
[ "" ] [ "\n" ends-with-newline? ] unit-test
[ f ] [ "" ends-with-newline? ] unit-test
[ "Hello world" ] [ "Hello world\n" "\n" str-tail? ] unit-test
[ f ] [ "Hello world" "\n" str-tail? ] unit-test
[ "" ] [ "\n" "\n" str-tail? ] unit-test
[ f ] [ "" "\n" str-tail? ] unit-test
[ t ] [ 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
default-style append ;
: var. ( [ name | value ] -- )
uncons unparse swap link-style write-attr ;
: var-name. ( max name -- )
tuck unparse pad-string write dup link-style
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 ;
SYMBOL: meta-d
: push-d meta-d get vector-push ;
: peek-d meta-d get vector-peek ;
: pop-d meta-d get vector-pop ;
SYMBOL: meta-n
SYMBOL: meta-c
@ -79,7 +78,7 @@ SYMBOL: meta-cf
pop-r meta-cf set ;
: next ( -- obj )
meta-cf get [ meta-cf uncons@ ] [ up next ] ifte ;
meta-cf get [ meta-cf [ uncons ] change ] [ up next ] ifte ;
: host-word ( 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.
USE: kernel
USE: math
IN: math : fixnum? ( obj -- ? ) type 0 eq? ;
IN: words : word? ( obj -- ? ) type 1 eq? ;
IN: lists : cons? ( obj -- ? ) type 2 eq? ;
IN: math : ratio? ( obj -- ? ) type 4 eq? ;
IN: math : complex? ( obj -- ? ) type 5 eq? ;
IN: math : bignum? ( obj -- ? ) type 9 eq? ;
IN: math : float? ( obj -- ? ) type 10 eq? ;
IN: vectors : vector? ( obj -- ? ) type 11 eq? ;
IN: strings : string? ( obj -- ? ) type 12 eq? ;
IN: strings : sbuf? ( obj -- ? ) type 13 eq? ;
IN: io-internals : port? ( obj -- ? ) type 14 eq? ;
IN: alien : dll? ( obj -- ? ) type 15 eq? ;
IN: alien : alien? ( obj -- ? ) type 16 eq? ;
IN: kernel-internals
: fixnum-tag BIN: 000 ; inline
: word-tag BIN: 001 ; inline
: cons-tag BIN: 010 ; inline
: object-tag BIN: 011 ; inline
: ratio-tag BIN: 100 ; inline
: complex-tag BIN: 101 ; inline
: header-tag BIN: 110 ; inline
: f-type 6 ; inline
: t-type 7 ; inline
: 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

2
library/vector-combinators.factor
View File

@ -68,7 +68,7 @@ USE: math
#! Make a new vector with each pair of elements from the
#! first two in a pair.
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-2map ( v1 v2 quot -- v )

11
library/vectors.factor
View File

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

1
library/words.factor
View File

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