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

random number generation and other goodies

cvs
Slava Pestov 2004-08-04 22:25:29 +00:00
parent f68cc94ee4
commit faa6913759
34 changed files with 443 additions and 773 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TODO.FACTOR.txt
View File

@ -3,7 +3,6 @@
ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable" ]
- prettyprinter: space after #<>, space after ~<< foo
- bignum=
- fixup-words is crusty
- decide if overflow is a fatal error
- f >n: crashes
@ -16,7 +15,6 @@ ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable
- contains ==> contains?
- telnetd: send errors on socket
- inspector: sort
- index of str
- accept: return socket, instead of printing msg
- enforce bottom-up in native bootstrap

13
library/cross-compiler.factor
View File

@ -39,6 +39,9 @@ USE: vectors
USE: vocabularies
USE: words
IN: arithmetic
DEFER: number=
IN: kernel
DEFER: getenv
DEFER: setenv
@ -61,6 +64,10 @@ DEFER: write-fd-8
DEFER: flush-fd
DEFER: shutdown-fd
IN: random
DEFER: init-random
DEFER: (random-int)
IN: words
DEFER: <word>
DEFER: word-primitive
@ -105,6 +112,10 @@ IN: cross-compiler
set-sbuf-nth
sbuf-append
sbuf>str
number?
>fixnum
>bignum
number=
fixnum?
bignum?
+
@ -163,6 +174,8 @@ IN: cross-compiler
room
os-env
millis
init-random
(random-int)
] [
swap succ tuck primitive,
] each drop ;

3
library/platform/native/boot.factor
View File

@ -66,6 +66,7 @@ primitives,
"/library/logic.factor"
"/library/namespaces.factor"
"/library/prettyprint.factor"
"/library/random.factor"
"/library/sbuf.factor"
"/library/stdio.factor"
"/library/stream.factor"
@ -91,7 +92,9 @@ primitives,
"/library/platform/native/parse-syntax.factor"
"/library/platform/native/parse-stream.factor"
"/library/platform/native/prettyprint.factor"
"/library/platform/native/random.factor"
"/library/platform/native/stack.factor"
"/library/platform/native/strings.factor"
"/library/platform/native/words.factor"
"/library/platform/native/vocabularies.factor"
"/library/platform/native/unparser.factor"

9
library/platform/native/init.factor
View File

@ -37,6 +37,7 @@ USE: logic
USE: interpreter
USE: io-internals
USE: math
USE: random
USE: namespaces
USE: parser
USE: prettyprint
@ -55,19 +56,19 @@ USE: unparser
: boot ( -- )
init-gc
init-random
init-namespaces
init-stdio
"stdio" get <ansi-stream> "stdio" set
! Some flags are *on* by default, unless user specifies
! -no-<flag> CLI switch
t "user-init" set
t "interactive" set
init-stdio
"stdio" get <ansi-stream> "stdio" set
"HOME" os-env [ "." ] unless* "~" set
"/" "/" set
10 "base" set
init-errors
init-search-path
init-scratchpad

3
library/platform/native/kernel.factor
View File

@ -48,7 +48,7 @@ USE: unparser
[ cons? ] [ 4 cons-hashcode ]
[ string? ] [ str-hashcode ]
[ fixnum? ] [ ( return the object ) ]
[ bignum? ] [ ( return the object ) ]
[ bignum? ] [ >fixnum ]
[ drop t ] [ drop 0 ]
] cond ;
@ -58,6 +58,7 @@ USE: unparser
2drop t
] [
[
[ number? ] [ number= ]
[ cons? ] [ cons= ]
[ string? ] [ str= ]
[ drop t ] [ 2drop f ]

4
library/platform/native/parse-numbers.factor
View File

@ -41,10 +41,6 @@ USE: unparser
! Number parsing
: letter? CHAR: a CHAR: z between? ;
: LETTER? CHAR: A CHAR: Z between? ;
: digit? CHAR: 0 CHAR: 9 between? ;
: not-a-number "Not a number" throw ;
: digit> ( ch -- n )

8
library/platform/native/parse-syntax.factor
View File

@ -84,14 +84,14 @@ USE: unparser
: IN: scan dup "use" cons@ "in" set ; parsing
! \x
: unicode-escape ( -- esc )
: unicode-escape>ch ( -- esc )
#! Read \u....
next-ch digit> 16 *
next-ch digit> + 16 *
next-ch digit> + 16 *
next-ch digit> + ;
: ascii-escape ( ch -- esc )
: ascii-escape>ch ( ch -- esc )
[
[ CHAR: e | CHAR: \e ]
[ CHAR: n | CHAR: \n ]
@ -106,9 +106,9 @@ USE: unparser
: escape ( ch -- esc )
dup CHAR: u = [
drop unicode-escape
drop unicode-escape>ch
] [
ascii-escape
ascii-escape>ch
] ifte ;
! String literal

56
library/platform/native/random.factor Normal file
View File

@ -0,0 +1,56 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 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: random
USE: arithmetic
USE: kernel
USE: stack
: power-of-2? ( n -- ? )
dup dup neg bitand = ;
: (random-int-0) ( n bits val -- n )
3dup - + pred 0 < [
2drop (random-int) 2dup swap mod (random-int-0)
] [
nip nip
] ifte ;
: random-int-0 ( max -- n )
succ dup power-of-2? [
(random-int) * 31 shift>
] [
(random-int) 2dup swap mod (random-int-0)
] ifte ;
: random-int ( min max -- n )
dupd swap - random-int-0 + ;
: random-boolean ( -- ? )
0 1 random-int 0 = ;
! TODO: : random-float ... ;

42
library/platform/native/strings.factor Normal file
View File

@ -0,0 +1,42 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 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: strings
USE: arithmetic
USE: kernel
USE: logic
USE: stack
: letter? CHAR: a CHAR: z between? ;
: LETTER? CHAR: A CHAR: Z between? ;
: digit? CHAR: 0 CHAR: 9 between? ;
: printable? CHAR: \s CHAR: ~ between? ;
: quotable? ( ch -- ? )
#! In a string literal, can this character be used without
#! escaping?
dup printable? swap "\"\\" str-contains? not and ;

27
library/platform/native/unparser.factor
View File

@ -29,6 +29,7 @@ IN: unparser
USE: arithmetic
USE: combinators
USE: kernel
USE: format
USE: lists
USE: logic
USE: namespaces
@ -68,9 +69,31 @@ USE: vocabularies
#! Convert a number to its hexadecimal representation.
16 >base ;
: ch>ascii-escape ( ch -- esc )
[
[ CHAR: \e | "\\e" ]
[ CHAR: \n | "\\n" ]
[ CHAR: \r | "\\r" ]
[ CHAR: \t | "\\t" ]
[ CHAR: \0 | "\\0" ]
[ CHAR: \\ | "\\\\" ]
[ CHAR: \" | "\\\"" ]
] assoc ;
: ch>unicode-escape ( ch -- esc )
>hex 4 digits "\\u" swap cat2 ;
: unparse-ch ( ch -- ch/str )
dup quotable? [
dup ch>ascii-escape dup [
nip
] [
drop ch>unicode-escape
] ifte
] unless ;
: unparse-str ( str -- str )
#! Escapes not done
<% CHAR: " % % CHAR: " % %> ;
<% CHAR: " % [ unparse-ch % ] str-each CHAR: " % %> ;
: unparse-word ( word -- str )
word-name dup "#<unnamed>" ? ;

78
library/test/auxiliary.factor
View File

@ -1,78 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: combinators
USE: kernel
USE: stack
USE: stdio
USE: test
USE: words
"Check compiler's auxiliary quotation code." print
: [call] call ; inline
: [[call]] [call] ; inline
: [nop] [ nop ] call ; word must-compile
: [[nop]] [ nop ] [call] ; word must-compile
: [[[nop]]] [ nop ] [[call]] ; word must-compile
[ ] [ ] [ [nop] ] test-word
[ ] [ ] [ [[nop]] ] test-word
[ ] [ ] [ [[[nop]]] ] test-word
: ?call t [ call ] [ drop ] ifte ; inline
: ?nop [ nop ] ?call ; word must-compile
: ??call t [ call ] [ ?call ] ifte ; inline
: ??nop [ nop ] ??call ; word must-compile
: ???call t [ call ] [ ???call ] ifte ; inline
: ???nop [ nop ] ???call ; word must-compile
[ ] [ ] [ ?nop ] test-word
[ ] [ ] [ ??nop ] test-word
[ ] [ ] [ ???nop ] test-word
: while-test [ f ] [ ] while ; word must-compile
[ ] [ ] [ while-test ] test-word
: [while]
[ over call ] [ dup 2dip ] while 2drop ; inline
: [while-test] [ f ] [ ] [while] ; word must-compile
[ ] [ ] [ [while-test] ] test-word
: times-test-1 [ nop ] times ; word must-compile
: times-test-2 [ succ ] times ; word must-compile
: times-test-3 0 10 [ succ ] times ; word must-compile
[ ] [ 10 ] [ times-test-1 ] test-word
[ 10 ] [ 0 10 ] [ times-test-2 ] test-word
[ 10 ] [ ] [ times-test-3 ] test-word
: nested-ifte [ [ 1 ] [ 2 ] ifte ] [ [ 3 ] [ 4 ] ifte ] ifte ; word must-compile
[ 1 ] [ t t ] [ nested-ifte ] test-word
[ 2 ] [ f t ] [ nested-ifte ] test-word
[ 3 ] [ t f ] [ nested-ifte ] test-word
[ 4 ] [ f f ] [ nested-ifte ] test-word
: flow-erasure [ 2 2 + ] [ ] dip call ; inline word must-compile
[ 4 ] [ ] [ flow-erasure ] test-word
! This got broken when I changed : ifte ? call ; to primitive
: twice-nested-ifte
t [
t [
] [
twice-nested-ifte
] ifte
] [
] ifte ; word must-compile
"Auxiliary quotation checks done." print

25
library/test/compiler-types.factor
View File

@ -1,25 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: combinators
USE: compiler
USE: kernel
USE: lists
USE: logic
USE: math
USE: stack
USE: stdio
USE: test
USE: words
"Checking compiler type coercions." print
: >boolean [ "boolean" ] "java.lang.Boolean" jnew ; word must-compile
: >byte [ "byte" ] "java.lang.Byte" jnew ; word must-compile
: >char [ "char" ] "java.lang.Character" jnew ; word must-compile
: >short [ "short" ] "java.lang.Short" jnew ; word must-compile
: >int [ "int" ] "java.lang.Integer" jnew ; word must-compile
: >float [ "float" ] "java.lang.Float" jnew ; word must-compile
: >long [ "long" ] "java.lang.Long" jnew ; word must-compile
: >double [ "double" ] "java.lang.Double" jnew ; word must-compile
"Type coercion checks done." print

108
library/test/compiler.factor
View File

@ -1,108 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: combinators
USE: compiler
USE: inspector
USE: kernel
USE: lists
USE: logic
USE: math
USE: stack
USE: stdio
USE: test
USE: words
"Checking compiler." print
[ 1 2 3 ] [ 4 5 6 ] [ t [ 3drop 1 2 3 ] when ] test-word
[ 4 5 6 ] [ 4 5 6 ] [ f [ 3drop 1 2 3 ] when ] test-word
[ t ] [ t ] [ [ t ] [ f ] rot [ drop call ] [ nip call ] ifte ] test-word
[ f ] [ f ] [ [ t ] [ f ] rot [ drop call ] [ nip call ] ifte ] test-word
[ 4 ] [ 2 ] [ t [ 2 ] [ 3 ] ifte + ] test-word
[ 5 ] [ 2 ] [ f [ 2 ] [ 3 ] ifte + ] test-word
: stack-frame-test ( x -- x )
>r t [ r> ] [ r> drop 11 ] ifte ; word must-compile
[ 10 ] [ 10 ] [ stack-frame-test ] test-word
[ [ 1 1 0 0 ] ] [ [ sq ] ] [ balance>list ] test-word
[ [ 2 1 0 0 ] ] [ [ mag2 ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ fac ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ fib ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ balance ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ dup [ sq ] when ] ] [ balance>list ] test-word
: null-rec ( -- )
t [ null-rec ] when ; word must-compile
[ [ 0 0 0 0 ] ] [ [ null-rec ] ] [ balance>list ] test-word
: null-rec ( -- )
t [ null-rec ] unless ; word must-compile
[ [ 0 0 0 0 ] ] [ [ null-rec ] ] [ balance>list ] test-word
: null-rec ( -- )
t [ drop null-rec ] when* ; word must-compile
[ [ 0 0 0 0 ] ] [ [ null-rec ] ] [ balance>list ] test-word
!: null-rec ( -- )
! t [ t null-rec ] unless* drop ; word must-compile test-null-rec
[ f 1 2 3 ] [ [ [ 2 | 1 ] ] 3 ] [ [ unswons unswons ] dip ] test-word
[ [ 2 1 0 0 ] ] [ [ >r [ ] [ ] ifte r> ] ] [ balance>list ] test-word
: nested-rec ( -- )
t [ nested-rec ] when ; word must-compile
: nested-rec-test ( -- )
5 nested-rec drop ; word must-compile
[ [ 0 0 0 0 ] ] [ [ nested-rec-test ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ relative>absolute-object-path ] ] [ balance>list ] test-word
! We had a problem with JVM stack overflow...
: null-inject [ ] inject ; word must-compile
! And a problem with stack normalization after ifte if both
! datastack and callstack were in use...
: inject-test [ dup [ ] when ] inject ; word must-compile
[ [ 1 2 3 ] ] [ [ 1 2 3 ] ] [ inject-test ] test-word
: nested-test-iter f [ nested-test-iter ] when ;
: nested-test f nested-test-iter drop ; word must-compile
! Attempts at making setFields() lazy exposed some bugs with
! recursive compilations.
"car" decompile
"cdr" decompile
: nested-test-inline dup cdr swap car ; inline
: nested-test nested-test-inline ;
: nested-test-2 nested-test ; word must-compile
! Not all words that we compile calls do are from a
! FactorClassLoader; eg, primitives.
: calling-primitive-core define ; word must-compile
! Making sure compilation of these never breaks again for
! various reasons
"balance" must-compile
"decompile" must-compile
: 3-recurse ( -- )
t [ t [ 3-recurse ] when ] [ 3-recurse ] ifte ;
word must-compile
"All compiler checks passed." print

72
library/test/dictionary.factor
View File

@ -1,72 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: combinators
USE: continuations
USE: kernel
USE: lists
USE: logic
USE: namespaces
USE: stack
USE: stdio
USE: strings
USE: test
USE: vocabularies
USE: words
"Checking dictionary words." print
! Just make sure this works.
! OUTPUT INPUT WORD
[ ] [ "httpd" ] [ apropos. ] test-word
[ t ] [ "when" ] [ worddef compound? ] test-word
[ t ] [ "dup" ] [ worddef shuffle? ] test-word
[ f ] [ "ifte" ] [ worddef shuffle? ] test-word
[ f ] [ "dup" ] [ worddef compound? ] test-word
! Test word internalization.
: gensym-test ( -- ? )
f 10 [ gensym gensym = and ] times ;
[ f ] [ ] [ gensym-test ] test-word
: intern-test ( 1 2 -- ? )
[ intern ] 2apply = ;
[ f ] [ "#:a" "#:a" ] [ intern-test ] test-word
[ t ] [ "#:" "#:" ] [ intern-test ] test-word
: worddef>list-test ( -- ? )
[ dup * ] dup no-name worddef>list = ;
[ t ] [ ] [ worddef>list-test ] test-word
: words-test ( -- ? )
t vocabs [ words [ word? and ] each ] each ;
[ t ] [ ] [ words-test ] test-word
! At one time we had a bug in FactorShuffleDefinition.toList()
~<< test-shuffle-1 A r:B -- A r:B >>~
[ [ "A" "r:B" "--" "A" "r:B" ] ]
[ "test-shuffle-1" ]
[ worddef>list ]
test-word
~<< test-shuffle-2 A B -- r:A r:B >>~
[ [ "A" "B" "--" "r:A" "r:B" ] ]
[ "test-shuffle-2" ]
[ worddef>list ]
test-word
~<< test-shuffle-3 A r:B r:C r:D r:E -- A C D E >>~
[ [ "A" "r:B" "r:C" "r:D" "r:E" "--" "A" "C" "D" "E" ] ]
[ "test-shuffle-3" ]
[ worddef>list ]
test-word
"car" usages.

42
library/test/inference.factor
View File

@ -1,42 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: compiler
USE: lists
USE: math
USE: stack
USE: stdio
USE: test
"Checking type inference." print
![ [ [ "java.lang.Number" "java.lang.Number" ] [ "java.lang.Number" ] f f ] ]
![ [ + ] ]
![ balance>typelist ]
!test-word
!
![ [ [ "factor.Cons" ] [ "java.lang.Object" ] f f ] ]
![ [ car ] ]
![ balance>typelist ]
!test-word
!
![ [ [ "factor.Cons" "java.lang.Object" ] f f f ] ]
![ [ set-car ] ]
![ balance>typelist ]
!test-word
!
![ [ [ "java.lang.Number" "java.lang.Number" ] [ "java.lang.Number" ] f f ] ]
![ [ swap + ] ]
![ balance>typelist ]
!test-word
!
![ [ [ "java.lang.Integer" ] [ "java.lang.Integer" ] f f ] ]
![ [ >fixnum ] ]
![ balance>typelist ]
!test-word
!
![ [ [ "java.lang.Number" ] [ "java.lang.Number" "java.lang.Number" ] f f ] ]
![ [ >rect ] ]
![ balance>typelist ]
!test-word
"Type inference checks done." print

9
library/test/inspector.factor Normal file
View File

@ -0,0 +1,9 @@
IN: scratchpad
USE: inspector
USE: namespaces
USE: vocabularies
"httpd" apropos.
"car" usages.
global describe
"vocabularies" get describe

1
library/test/math.factor
View File

@ -37,7 +37,6 @@ USE: test
[ t ] [ 30 2^ ] [ fixnum? ] test-word
[ t ] [ 32 2^ ] [ bignum? ] test-word
[ -1 ] [ 1 ] [ neg ] test-word
[ 2.1 ] [ -2.1 ] [ neg ] test-word
! Make sure equality testing works.

71
library/test/miscellaneous.factor
View File

@ -1,71 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: combinators
USE: compiler
USE: errors
USE: inspector
USE: kernel
USE: lists
USE: logic
USE: namespaces
USE: random
USE: stack
USE: stdio
USE: strings
USE: test
USE: words
USE: vocabularies
"Miscellaneous tests." print
[ [ 2 1 0 0 ] ] [ [ = ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ class-of ] ] [ balance>list ] test-word
[ "java.lang.Integer" ] [ 5 ] [ class-of ] test-word
[ "java.lang.Double" ] [ 5.0 ] [ class-of ] test-word
[ [ 1 1 0 0 ] ] [ [ clone ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ clone-array ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ comment? ] ] [ balance>list ] test-word
: doc-test ( -- ) ;
[ t ] [ "doc-test" ] [ intern worddef>list car comment? ] test-word
[ [ 1 1 0 0 ] ] [ [ deep-clone-array ] ] [ balance>list ] test-word
[ [ 2 1 0 0 ] ] [ [ is ] ] [ balance>list ] test-word
[ t ] [ "java.lang.Integer" ] [ 0 100 random-int swap is ] test-word
[ t ] [ "java.lang.Object" ] [ [ 5 ] swap is ] test-word
[ f ] [ "java.lang.Object" ] [ f swap is ] test-word
[ [ 5 1 0 0 ] ] [ [ >=< ] ] [ balance>list ] test-word
[ [ 1 0 0 0 ] ] [ [ exit* ] ] [ balance>list ] test-word
[ [ 0 1 0 0 ] ] [ [ millis ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ system-property ] ] [ balance>list ] test-word
: test-last ( -- )
nop ;
word >str "last-word-test" set
[ "test-last" ] [ ] [ "last-word-test" get ] test-word
[ f ] [ 5 ] [ compound? ] test-word
[ f ] [ 5 ] [ compiled? ] test-word
[ f ] [ 5 ] [ shuffle? ] test-word
[ t ] [ ] [
[ "global" "vocabularies" "test" "test-word" ] object-path
"test-word" [ "test" ] search eq?
] test-word
! Make sure callstack only clones callframes, and not
! everything on the callstack.
[ ] [ ] [ f unit dup dup set-cdr >r callstack r> 2drop ] test-word
"Miscellaneous passed." print

15
library/test/reader.factor → library/test/parser.factor
View File

@ -38,11 +38,6 @@ test-word
[ parse call ]
test-word
[ "\"hello\\\\backslash\"" ]
[ "hello\\backslash" ]
[ unparse ]
test-word
! Test escapes
[ [ " " ] ]
@ -54,13 +49,3 @@ test-word
[ "\"\\u0027\"" ]
[ parse ]
test-word
[ "\"\\u1234\"" ]
[ "\u1234" ]
[ unparse ]
test-word
[ "\"\\e\"" ]
[ "\e" ]
[ unparse ]
test-word

31
library/test/primitives.factor
View File

@ -1,31 +0,0 @@
IN: scratchpad
USE: stdio
USE: test
"Checking primitive compilation." print
! jvar-get
"car" must-compile
! jvar-set
"set-car" must-compile
! jvar-get-static
"version" must-compile
! jnew
"cons" must-compile
"<namespace>" must-compile
! jinvoke with return value
">str" must-compile
"is" must-compile
! jinvoke without return value
"set" must-compile
! jinvoke-static
">rect" must-compile
"+" must-compile
"Primitive compilation checks done." print

20
library/test/random.factor
View File

@ -5,15 +5,12 @@ USE: lists
USE: logic
USE: namespaces
USE: random
USE: stdio
USE: stack
USE: test
"Checking random number generation." print
[ t ]
[ [ 1 2 3 ] ]
[ random-element number? ]
test-word
[ [ 1 2 3 ] random-element number? ]
unit-test
[
[ 10 | t ]
@ -22,7 +19,12 @@ test-word
] "random-pairs" set
[ f ]
[ "random-pairs" get ]
[ random-element* [ t f "monkey" ] contains not ] test-word
[
"random-pairs" get
random-element* [ t f "monkey" ] contains not
] unit-test
"Random number checks complete." print
: check-random-int ( min max -- )
2dup random-int -rot between? assert ;
[ ] [ 100 [ -12 674 check-random-int ] times ] unit-test

24
library/test/recompile.factor
View File

@ -1,24 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: compiler
USE: kernel
USE: stdio
USE: test
USE: words
USE: vocabularies
"Recompile test." print
: recompile-test 2 2 + ; word must-compile
: recompile-dependency recompile-test 3 * ; word must-compile
[ 4 ] [ ] [ recompile-test ] test-word
[ 12 ] [ ] [ recompile-dependency ] test-word
: recompile-test 2 3 + ; word must-compile
"recompile-dependency" [ "scratchpad" ] search recompile
[ 15 ] [ ] [ recompile-dependency ] test-word
"Recompile test done." print

40
library/test/stack.factor
View File

@ -1,40 +0,0 @@
IN: scratchpad
USE: compiler
USE: stack
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

58
library/test/tail.factor
View File

@ -1,58 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: combinators
USE: kernel
USE: lists
USE: prettyprint
USE: stack
USE: stdio
USE: test
USE: words
! Test tail recursive compilation.
"Checking tail call optimization." print
! Make sure we're doing *some* form of tail call optimization.
! Without it, this will overflow the stack.
: tail-call-0 1000 [ ] times ; word must-compile tail-call-0
: tail-call-1 ( -- )
t [ ] [ tail-call-1 ] ifte ; word must-compile
[ ] [ ] [ tail-call-1 ] test-word
: tail-call-2 ( list -- f )
[ dup cons? ] [ uncons nip ] while ; word must-compile
[ f ] [ [ 1 2 3 ] ] [ tail-call-2 ] test-word
: tail-call-3 ( x y -- z )
[ dup succ ] dip swap 6 = [
+
] [
swap tail-call-3
] ifte ; word must-compile
[ 15 ] [ 10 5 ] [ tail-call-3 ] test-word
: tail-call-4 ( element tree -- ? )
dup [
2dup car = [
nip
] [
cdr dup cons? [
tail-call-4
] [
! don't bomb on dotted pairs
=
] ifte
] ifte
] [
2drop f
] ifte ; word must-compile
3 [ 1 2 [ 3 4 ] 5 6 ] tail-call-4 .
"Tail call optimization checks done." print

20
library/test/test.factor
View File

@ -57,26 +57,18 @@ USE: vocabularies
"strings"
"namespaces/all"
"format"
"parser"
"prettyprint"
"inspector"
"vectors"
"unparser"
"random"
!
"html"
"auxiliary"
"compiler"
"compiler-types"
"dictionary"
"httpd"
"inference"
"math"
"miscellaneous"
"parse-number"
"primitives"
"random"
"reader"
"recompile"
"stack"
"tail"
"types"
"vectors"
"jvm-compiler/all"
] [
test
] each ;

15
library/test/types.factor
View File

@ -1,15 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: compiler
USE: lists
USE: stack
USE: stdio
USE: strings
USE: test
"Checking type coercion." print
[ 32 ] [ " " ] [ >char >number ] test-word
[ 32 ] [ " " ] [ >char >fixnum ] test-word
"Type coercion checks done." print

19
library/test/unparser.factor Normal file
View File

@ -0,0 +1,19 @@
IN: scratchpad
USE: parser
USE: test
USE: unparser
[ "\"hello\\\\backslash\"" ]
[ "hello\\backslash" ]
[ unparse ]
test-word
[ "\"\\u1234\"" ]
[ "\u1234" ]
[ unparse ]
test-word
[ "\"\\e\"" ]
[ "\e" ]
[ unparse ]
test-word

6
library/test/vectors.factor
View File

@ -1,13 +1,11 @@
USE: arithmetic
USE: lists
USE: stdio
USE: stack
USE: test
USE: vectors
"Vector tests." print
[ [ 1 4 9 16 ] ] [ [ 1 2 3 4 ] ]
[ list>vector [ sq ] vector-map vector>list ] test-word
[ list>vector [ dup * ] vector-map vector>list ] test-word
[ t ] [ [ 1 2 3 4 ] ]
[ list>vector [ number? ] vector-all? ] test-word
[ f ] [ [ 1 2 3 4 ] ]

189
native/arithmetic.c
View File

@ -1,5 +1,21 @@
#include "factor.h"
void primitive_numberp(void)
{
check_non_empty(env.dt);
switch(type_of(env.dt))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
return T;
break;
default:
return F;
break;
}
}
FIXNUM to_fixnum(CELL tagged)
{
switch(type_of(tagged))
@ -14,206 +30,249 @@ FIXNUM to_fixnum(CELL tagged)
}
}
void primitive_to_fixnum(void)
{
return tag_fixnum(to_fixnum(env.dt));
}
BIGNUM* to_bignum(CELL tagged)
{
switch(type_of(tagged))
{
case FIXNUM_TYPE:
return fixnum_to_bignum(tagged);
case BIGNUM_TYPE:
return tagged;
default:
type_error(BIGNUM_TYPE,tagged);
return -1; /* can't happen */
}
}
void primitive_to_bignum(void)
{
return tag_bignum(to_bignum(env.dt));
}
/* EQUALITY */
INLINE CELL number_eq_fixnum(CELL x, CELL y)
{
return tag_boolean(x == y);
}
CELL number_eq_bignum(CELL x, CELL y)
{
return tag_boolean(((BIGNUM*)UNTAG(x))->n
== ((BIGNUM*)UNTAG(y))->n);
}
CELL number_eq_anytype(CELL x, CELL y)
{
return F;
}
BINARY_OP(number_eq,true)
/* ADDITION */
INLINE void add_fixnum(CELL x, CELL y)
INLINE CELL add_fixnum(CELL x, CELL y)
{
CELL_TO_INTEGER(untag_fixnum_fast(x) + untag_fixnum_fast(y));
}
void add_bignum(CELL x, CELL y)
CELL add_bignum(CELL x, CELL y)
{
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
+ ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(add)
BINARY_OP(add,false)
/* SUBTRACTION */
INLINE void subtract_fixnum(CELL x, CELL y)
INLINE CELL subtract_fixnum(CELL x, CELL y)
{
CELL_TO_INTEGER(untag_fixnum_fast(x) - untag_fixnum_fast(y));
}
void subtract_bignum(CELL x, CELL y)
CELL subtract_bignum(CELL x, CELL y)
{
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
- ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(subtract)
BINARY_OP(subtract,false)
/* MULTIPLICATION */
INLINE void multiply_fixnum(CELL x, CELL y)
INLINE CELL multiply_fixnum(CELL x, CELL y)
{
BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
* (BIGNUM_2)untag_fixnum_fast(y));
}
void multiply_bignum(CELL x, CELL y)
CELL multiply_bignum(CELL x, CELL y)
{
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
* ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(multiply)
BINARY_OP(multiply,false)
/* DIVMOD */
INLINE void divmod_fixnum(CELL x, CELL y)
INLINE CELL divmod_fixnum(CELL x, CELL y)
{
ldiv_t q = ldiv(x,y);
/* division takes common factor of 8 out. */
dpush(tag_fixnum(q.quot));
env.dt = q.rem;
return q.rem;
}
void divmod_bignum(CELL x, CELL y)
CELL divmod_bignum(CELL x, CELL y)
{
dpush(tag_object(bignum(((BIGNUM*)UNTAG(x))->n
/ ((BIGNUM*)UNTAG(y))->n)));
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
% ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(divmod)
BINARY_OP(divmod,false)
/* MOD */
INLINE void mod_fixnum(CELL x, CELL y)
INLINE CELL mod_fixnum(CELL x, CELL y)
{
env.dt = x % y;
return x % y;
}
void mod_bignum(CELL x, CELL y)
CELL mod_bignum(CELL x, CELL y)
{
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
% ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(mod)
BINARY_OP(mod,false)
/* AND */
INLINE void and_fixnum(CELL x, CELL y)
INLINE CELL and_fixnum(CELL x, CELL y)
{
env.dt = x & y;
return x & y;
}
void and_bignum(CELL x, CELL y)
CELL and_bignum(CELL x, CELL y)
{
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
& ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(and)
BINARY_OP(and,false)
/* OR */
INLINE void or_fixnum(CELL x, CELL y)
INLINE CELL or_fixnum(CELL x, CELL y)
{
env.dt = x | y;
return x | y;
}
void or_bignum(CELL x, CELL y)
CELL or_bignum(CELL x, CELL y)
{
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
| ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(or)
BINARY_OP(or,false)
/* XOR */
INLINE void xor_fixnum(CELL x, CELL y)
INLINE CELL xor_fixnum(CELL x, CELL y)
{
env.dt = x ^ y;
return x ^ y;
}
void xor_bignum(CELL x, CELL y)
CELL xor_bignum(CELL x, CELL y)
{
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
^ ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(xor)
BINARY_OP(xor,false)
/* SHIFTLEFT */
INLINE void shiftleft_fixnum(CELL x, CELL y)
INLINE CELL shiftleft_fixnum(CELL x, CELL y)
{
BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
<< (BIGNUM_2)untag_fixnum_fast(y));
}
void shiftleft_bignum(CELL x, CELL y)
CELL shiftleft_bignum(CELL x, CELL y)
{
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
<< ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(shiftleft)
BINARY_OP(shiftleft,false)
/* SHIFTRIGHT */
INLINE void shiftright_fixnum(CELL x, CELL y)
INLINE CELL shiftright_fixnum(CELL x, CELL y)
{
BIGNUM_2_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
>> (BIGNUM_2)untag_fixnum_fast(y));
}
void shiftright_bignum(CELL x, CELL y)
CELL shiftright_bignum(CELL x, CELL y)
{
env.dt = tag_object(bignum(((BIGNUM*)UNTAG(x))->n
return tag_object(bignum(((BIGNUM*)UNTAG(x))->n
>> ((BIGNUM*)UNTAG(y))->n));
}
BINARY_OP(shiftright)
BINARY_OP(shiftright,false)
/* LESS */
INLINE void less_fixnum(CELL x, CELL y)
INLINE CELL less_fixnum(CELL x, CELL y)
{
env.dt = tag_boolean((FIXNUM)x < (FIXNUM)y);
return tag_boolean((FIXNUM)x < (FIXNUM)y);
}
void less_bignum(CELL x, CELL y)
CELL less_bignum(CELL x, CELL y)
{
env.dt = tag_boolean(((BIGNUM*)UNTAG(x))->n
return tag_boolean(((BIGNUM*)UNTAG(x))->n
< ((BIGNUM*)UNTAG(y))->n);
}
BINARY_OP(less)
BINARY_OP(less,false)
/* LESSEQ */
INLINE void lesseq_fixnum(CELL x, CELL y)
INLINE CELL lesseq_fixnum(CELL x, CELL y)
{
env.dt = tag_boolean((FIXNUM)x <= (FIXNUM)y);
return tag_boolean((FIXNUM)x <= (FIXNUM)y);
}
void lesseq_bignum(CELL x, CELL y)
CELL lesseq_bignum(CELL x, CELL y)
{
env.dt = tag_boolean(((BIGNUM*)UNTAG(x))->n
return tag_boolean(((BIGNUM*)UNTAG(x))->n
<= ((BIGNUM*)UNTAG(y))->n);
}
BINARY_OP(lesseq)
BINARY_OP(lesseq,false)
/* GREATER */
INLINE void greater_fixnum(CELL x, CELL y)
INLINE CELL greater_fixnum(CELL x, CELL y)
{
env.dt = tag_boolean((FIXNUM)x > (FIXNUM)y);
return tag_boolean((FIXNUM)x > (FIXNUM)y);
}
void greater_bignum(CELL x, CELL y)
CELL greater_bignum(CELL x, CELL y)
{
env.dt = tag_boolean(((BIGNUM*)UNTAG(x))->n
return tag_boolean(((BIGNUM*)UNTAG(x))->n
> ((BIGNUM*)UNTAG(y))->n);
}
BINARY_OP(greater)
BINARY_OP(greater,false)
/* GREATEREQ */
INLINE void greatereq_fixnum(CELL x, CELL y)
INLINE CELL greatereq_fixnum(CELL x, CELL y)
{
env.dt = tag_boolean((FIXNUM)x >= (FIXNUM)y);
return tag_boolean((FIXNUM)x >= (FIXNUM)y);
}
void greatereq_bignum(CELL x, CELL y)
CELL greatereq_bignum(CELL x, CELL y)
{
env.dt = tag_boolean(((BIGNUM*)UNTAG(x))->n
return tag_boolean(((BIGNUM*)UNTAG(x))->n
>= ((BIGNUM*)UNTAG(y))->n);
}
BINARY_OP(greatereq)
BINARY_OP(greatereq,false)

51
native/arithmetic.h
View File

@ -13,22 +13,20 @@ INLINE FIXNUM bignum_to_fixnum(CELL tagged)
#define CELL_TO_INTEGER(result) \
FIXNUM _result = (result); \
if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
env.dt = tag_bignum(fixnum_to_bignum(_result)); \
return tag_bignum(fixnum_to_bignum(_result)); \
else \
env.dt = tag_fixnum(_result);
return tag_fixnum(_result);
#define BIGNUM_2_TO_INTEGER(result) \
BIGNUM_2 _result = (result); \
if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
env.dt = tag_bignum(bignum(_result)); \
return tag_bignum(bignum(_result)); \
else \
env.dt = tag_fixnum(_result);
return tag_fixnum(_result);
#define BINARY_OP(OP) \
void primitive_##OP(void) \
#define BINARY_OP(OP,anytype) \
CELL OP(CELL x, CELL y) \
{ \
CELL x = dpop(), y = env.dt; \
\
switch(TAG(x)) \
{ \
case FIXNUM_TYPE: \
@ -36,20 +34,24 @@ void primitive_##OP(void) \
switch(TAG(y)) \
{ \
case FIXNUM_TYPE: \
OP##_fixnum(x,y); \
break; \
return OP##_fixnum(x,y); \
case OBJECT_TYPE: \
switch(object_type(y)) \
{ \
case BIGNUM_TYPE: \
OP##_bignum((CELL)fixnum_to_bignum(x),y); \
break; \
return OP##_bignum((CELL)fixnum_to_bignum(x),y); \
default: \
if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(FIXNUM_TYPE,y); \
break; \
} \
break; \
default: \
if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(FIXNUM_TYPE,y); \
break; \
} \
@ -66,14 +68,13 @@ void primitive_##OP(void) \
switch(TAG(y)) \
{ \
case FIXNUM_TYPE: \
OP##_bignum(x,(CELL)fixnum_to_bignum(y)); \
break; \
return OP##_bignum(x,(CELL)fixnum_to_bignum(y)); \
case OBJECT_TYPE: \
\
switch(object_type(y)) \
{ \
case BIGNUM_TYPE: \
OP##_bignum(x,y); \
return OP##_bignum(x,y); \
break; \
default: \
type_error(BIGNUM_TYPE,y); \
@ -81,6 +82,9 @@ void primitive_##OP(void) \
} \
break; \
default: \
if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(BIGNUM_TYPE,y); \
break; \
} \
@ -88,6 +92,9 @@ void primitive_##OP(void) \
\
default: \
\
if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(FIXNUM_TYPE,x); \
break; \
} \
@ -96,13 +103,27 @@ void primitive_##OP(void) \
\
default: \
\
if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(FIXNUM_TYPE,x); \
break; \
} \
} \
\
void primitive_##OP(void) \
{ \
CELL x = dpop(), y = env.dt; \
env.dt = OP(x,y); \
}
void primitive_numberp(void);
FIXNUM to_fixnum(CELL tagged);
void primitive_to_fixnum(void);
BIGNUM* to_bignum(CELL tagged);
void primitive_to_bignum(void);
void primitive_number_eq(void);
void primitive_add(void);
void primitive_subtract(void);
void primitive_multiply(void);

11
native/misc.c
View File

@ -29,3 +29,14 @@ void primitive_millis(void)
dpush(env.dt);
env.dt = tag_object(bignum(t.tv_sec * 1000 + t.tv_usec/1000));
}
void primitive_init_random(void)
{
srandomdev();
}
void primitive_random_int(void)
{
dpush(env.dt);
env.dt = tag_object(bignum(random()));
}

2
native/misc.h
View File

@ -2,3 +2,5 @@ void primitive_exit(void);
void primitive_os_env(void);
void primitive_eq(void);
void primitive_millis(void);
void primitive_init_random(void);
void primitive_random_int(void);

122
native/primitives.c
View File

@ -34,64 +34,70 @@ XT primitives[] = {
primitive_set_sbuf_nth, /* 30 */
primitive_sbuf_append, /* 31 */
primitive_sbuf_to_string, /* 32 */
primitive_fixnump, /* 33 */
primitive_bignump, /* 34 */
primitive_add, /* 35 */
primitive_subtract, /* 36 */
primitive_multiply, /* 37 */
primitive_divide, /* 38 */
primitive_mod, /* 39 */
primitive_divmod, /* 40 */
primitive_and, /* 41 */
primitive_or, /* 42 */
primitive_xor, /* 43 */
primitive_not, /* 44 */
primitive_shiftleft, /* 45 */
primitive_shiftright, /* 46 */
primitive_less, /* 47 */
primitive_lesseq, /* 48 */
primitive_greater, /* 49 */
primitive_greatereq, /* 50 */
primitive_wordp, /* 51 */
primitive_word, /* 52 */
primitive_word_primitive, /* 53 */
primitive_set_word_primitive, /* 54 */
primitive_word_parameter, /* 55 */
primitive_set_word_parameter, /* 56 */
primitive_word_plist, /* 57 */
primitive_set_word_plist, /* 58 */
primitive_drop, /* 59 */
primitive_dup, /* 60 */
primitive_swap, /* 61 */
primitive_over, /* 62 */
primitive_pick, /* 63 */
primitive_nip, /* 64 */
primitive_tuck, /* 65 */
primitive_rot, /* 66 */
primitive_to_r, /* 67 */
primitive_from_r, /* 68 */
primitive_eq, /* 69 */
primitive_getenv, /* 70 */
primitive_setenv, /* 71 */
primitive_open_file, /* 72 */
primitive_gc, /* 73 */
primitive_save_image, /* 74 */
primitive_datastack, /* 75 */
primitive_callstack, /* 76 */
primitive_set_datastack, /* 77 */
primitive_set_callstack, /* 78 */
primitive_handlep, /* 79 */
primitive_exit, /* 80 */
primitive_server_socket, /* 81 */
primitive_close_fd, /* 82 */
primitive_accept_fd, /* 83 */
primitive_read_line_fd_8, /* 84 */
primitive_write_fd_8, /* 85 */
primitive_flush_fd, /* 86 */
primitive_shutdown_fd, /* 87 */
primitive_room, /* 88 */
primitive_os_env, /* 89 */
primitive_millis /* 90 */
primitive_numberp, /* 33 */
primitive_to_fixnum, /* 34 */
primitive_to_bignum, /* 35 */
primitive_number_eq, /* 36 */
primitive_fixnump, /* 37 */
primitive_bignump, /* 38 */
primitive_add, /* 39 */
primitive_subtract, /* 40 */
primitive_multiply, /* 41 */
primitive_divide, /* 42 */
primitive_mod, /* 43 */
primitive_divmod, /* 44 */
primitive_and, /* 45 */
primitive_or, /* 46 */
primitive_xor, /* 47 */
primitive_not, /* 48 */
primitive_shiftleft, /* 49 */
primitive_shiftright, /* 50 */
primitive_less, /* 51 */
primitive_lesseq, /* 52 */
primitive_greater, /* 53 */
primitive_greatereq, /* 54 */
primitive_wordp, /* 55 */
primitive_word, /* 56 */
primitive_word_primitive, /* 57 */
primitive_set_word_primitive, /* 58 */
primitive_word_parameter, /* 59 */
primitive_set_word_parameter, /* 60 */
primitive_word_plist, /* 61 */
primitive_set_word_plist, /* 62 */
primitive_drop, /* 63 */
primitive_dup, /* 64 */
primitive_swap, /* 65 */
primitive_over, /* 66 */
primitive_pick, /* 67 */
primitive_nip, /* 68 */
primitive_tuck, /* 69 */
primitive_rot, /* 70 */
primitive_to_r, /* 71 */
primitive_from_r, /* 72 */
primitive_eq, /* 73 */
primitive_getenv, /* 74 */
primitive_setenv, /* 75 */
primitive_open_file, /* 76 */
primitive_gc, /* 77 */
primitive_save_image, /* 78 */
primitive_datastack, /* 79 */
primitive_callstack, /* 80 */
primitive_set_datastack, /* 81 */
primitive_set_callstack, /* 82 */
primitive_handlep, /* 83 */
primitive_exit, /* 84 */
primitive_server_socket, /* 85 */
primitive_close_fd, /* 86 */
primitive_accept_fd, /* 87 */
primitive_read_line_fd_8, /* 88 */
primitive_write_fd_8, /* 89 */
primitive_flush_fd, /* 90 */
primitive_shutdown_fd, /* 91 */
primitive_room, /* 92 */
primitive_os_env, /* 93 */
primitive_millis, /* 94 */
primitive_init_random, /* 95 */
primitive_random_int /* 96 */
};
CELL primitive_to_xt(CELL primitive)

4
native/primitives.h
View File

@ -1,6 +1,4 @@
extern XT primitives[];
#define PRIMITIVE_COUNT 91
#define PRIMITIVE_COUNT 97
CELL primitive_to_xt(CELL primitive);
void primitive_eq(void);