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

13
library/cross-compiler.factor
View File

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

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

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

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

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

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

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

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

@ -41,10 +41,6 @@ USE: unparser
! Number parsing ! 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 ; : not-a-number "Not a number" throw ;
: digit> ( ch -- n ) : 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 : IN: scan dup "use" cons@ "in" set ; parsing
! \x ! \x
: unicode-escape ( -- esc ) : unicode-escape>ch ( -- esc )
#! Read \u.... #! Read \u....
next-ch digit> 16 * next-ch digit> 16 *
next-ch digit> + 16 * next-ch digit> + 16 *
next-ch digit> + 16 * next-ch digit> + 16 *
next-ch digit> + ; next-ch digit> + ;
: ascii-escape ( ch -- esc ) : ascii-escape>ch ( ch -- esc )
[ [
[ CHAR: e | CHAR: \e ] [ CHAR: e | CHAR: \e ]
[ CHAR: n | CHAR: \n ] [ CHAR: n | CHAR: \n ]
@ -106,9 +106,9 @@ USE: unparser
: escape ( ch -- esc ) : escape ( ch -- esc )
dup CHAR: u = [ dup CHAR: u = [
drop unicode-escape drop unicode-escape>ch
] [ ] [
ascii-escape ascii-escape>ch
] ifte ; ] ifte ;
! String literal ! 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: arithmetic
USE: combinators USE: combinators
USE: kernel USE: kernel
USE: format
USE: lists USE: lists
USE: logic USE: logic
USE: namespaces USE: namespaces
@ -68,9 +69,31 @@ USE: vocabularies
#! Convert a number to its hexadecimal representation. #! Convert a number to its hexadecimal representation.
16 >base ; 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 ) : unparse-str ( str -- str )
#! Escapes not done <% CHAR: " % [ unparse-ch % ] str-each CHAR: " % %> ;
<% CHAR: " % % CHAR: " % %> ;
: unparse-word ( word -- str ) : unparse-word ( word -- str )
word-name dup "#<unnamed>" ? ; 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 ] [ 30 2^ ] [ fixnum? ] test-word
[ t ] [ 32 2^ ] [ bignum? ] test-word [ t ] [ 32 2^ ] [ bignum? ] test-word
[ -1 ] [ 1 ] [ neg ] test-word
[ 2.1 ] [ -2.1 ] [ neg ] test-word [ 2.1 ] [ -2.1 ] [ neg ] test-word
! Make sure equality testing works. ! 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 ] [ parse call ]
test-word test-word
[ "\"hello\\\\backslash\"" ]
[ "hello\\backslash" ]
[ unparse ]
test-word
! Test escapes ! Test escapes
[ [ " " ] ] [ [ " " ] ]
@ -54,13 +49,3 @@ test-word
[ "\"\\u0027\"" ] [ "\"\\u0027\"" ]
[ parse ] [ parse ]
test-word 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: logic
USE: namespaces USE: namespaces
USE: random USE: random
USE: stdio USE: stack
USE: test USE: test
"Checking random number generation." print
[ t ] [ t ]
[ [ 1 2 3 ] ] [ [ 1 2 3 ] random-element number? ]
[ random-element number? ] unit-test
test-word
[ [
[ 10 | t ] [ 10 | t ]
@ -22,7 +19,12 @@ test-word
] "random-pairs" set ] "random-pairs" set
[ f ] [ 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" "strings"
"namespaces/all" "namespaces/all"
"format" "format"
"parser"
"prettyprint" "prettyprint"
"inspector"
"vectors"
"unparser"
"random"
! !
"html" "html"
"auxiliary"
"compiler"
"compiler-types"
"dictionary"
"httpd" "httpd"
"inference"
"math" "math"
"miscellaneous"
"parse-number" "parse-number"
"primitives" "jvm-compiler/all"
"random"
"reader"
"recompile"
"stack"
"tail"
"types"
"vectors"
] [ ] [
test test
] each ; ] 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: arithmetic
USE: lists USE: lists
USE: stdio USE: stack
USE: test USE: test
USE: vectors USE: vectors
"Vector tests." print
[ [ 1 4 9 16 ] ] [ [ 1 2 3 4 ] ] [ [ 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 ] ] [ t ] [ [ 1 2 3 4 ] ]
[ list>vector [ number? ] vector-all? ] test-word [ list>vector [ number? ] vector-all? ] test-word
[ f ] [ [ 1 2 3 4 ] ] [ f ] [ [ 1 2 3 4 ] ]

189
native/arithmetic.c
View File

@ -1,5 +1,21 @@
#include "factor.h" #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) FIXNUM to_fixnum(CELL tagged)
{ {
switch(type_of(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 */ /* 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)); 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)); + ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(add) BINARY_OP(add,false)
/* SUBTRACTION */ /* 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)); 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)); - ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(subtract) BINARY_OP(subtract,false)
/* MULTIPLICATION */ /* 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_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
* (BIGNUM_2)untag_fixnum_fast(y)); * (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)); * ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(multiply) BINARY_OP(multiply,false)
/* DIVMOD */ /* DIVMOD */
INLINE void divmod_fixnum(CELL x, CELL y) INLINE CELL divmod_fixnum(CELL x, CELL y)
{ {
ldiv_t q = ldiv(x,y); ldiv_t q = ldiv(x,y);
/* division takes common factor of 8 out. */ /* division takes common factor of 8 out. */
dpush(tag_fixnum(q.quot)); 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 dpush(tag_object(bignum(((BIGNUM*)UNTAG(x))->n
/ ((BIGNUM*)UNTAG(y))->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)); % ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(divmod) BINARY_OP(divmod,false)
/* MOD */ /* 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)); % ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(mod) BINARY_OP(mod,false)
/* AND */ /* 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)); & ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(and) BINARY_OP(and,false)
/* OR */ /* 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)); | ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(or) BINARY_OP(or,false)
/* XOR */ /* 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)); ^ ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(xor) BINARY_OP(xor,false)
/* SHIFTLEFT */ /* 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_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
<< (BIGNUM_2)untag_fixnum_fast(y)); << (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)); << ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(shiftleft) BINARY_OP(shiftleft,false)
/* SHIFTRIGHT */ /* 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_TO_INTEGER((BIGNUM_2)untag_fixnum_fast(x)
>> (BIGNUM_2)untag_fixnum_fast(y)); >> (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)); >> ((BIGNUM*)UNTAG(y))->n));
} }
BINARY_OP(shiftright) BINARY_OP(shiftright,false)
/* LESS */ /* 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); < ((BIGNUM*)UNTAG(y))->n);
} }
BINARY_OP(less) BINARY_OP(less,false)
/* LESSEQ */ /* 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); <= ((BIGNUM*)UNTAG(y))->n);
} }
BINARY_OP(lesseq) BINARY_OP(lesseq,false)
/* GREATER */ /* 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); > ((BIGNUM*)UNTAG(y))->n);
} }
BINARY_OP(greater) BINARY_OP(greater,false)
/* GREATEREQ */ /* 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); >= ((BIGNUM*)UNTAG(y))->n);
} }
BINARY_OP(greatereq) BINARY_OP(greatereq,false)

61
native/arithmetic.h
View File

@ -13,22 +13,20 @@ INLINE FIXNUM bignum_to_fixnum(CELL tagged)
#define CELL_TO_INTEGER(result) \ #define CELL_TO_INTEGER(result) \
FIXNUM _result = (result); \ FIXNUM _result = (result); \
if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \ if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
env.dt = tag_bignum(fixnum_to_bignum(_result)); \ return tag_bignum(fixnum_to_bignum(_result)); \
else \ else \
env.dt = tag_fixnum(_result); return tag_fixnum(_result);
#define BIGNUM_2_TO_INTEGER(result) \ #define BIGNUM_2_TO_INTEGER(result) \
BIGNUM_2 _result = (result); \ BIGNUM_2 _result = (result); \
if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \ if(_result < FIXNUM_MIN || _result > FIXNUM_MAX) \
env.dt = tag_bignum(bignum(_result)); \ return tag_bignum(bignum(_result)); \
else \ else \
env.dt = tag_fixnum(_result); return tag_fixnum(_result);
#define BINARY_OP(OP) \ #define BINARY_OP(OP,anytype) \
void primitive_##OP(void) \ CELL OP(CELL x, CELL y) \
{ \ { \
CELL x = dpop(), y = env.dt; \
\
switch(TAG(x)) \ switch(TAG(x)) \
{ \ { \
case FIXNUM_TYPE: \ case FIXNUM_TYPE: \
@ -36,21 +34,25 @@ void primitive_##OP(void) \
switch(TAG(y)) \ switch(TAG(y)) \
{ \ { \
case FIXNUM_TYPE: \ case FIXNUM_TYPE: \
OP##_fixnum(x,y); \ return OP##_fixnum(x,y); \
break; \
case OBJECT_TYPE: \ case OBJECT_TYPE: \
switch(object_type(y)) \ switch(object_type(y)) \
{ \ { \
case BIGNUM_TYPE: \ case BIGNUM_TYPE: \
OP##_bignum((CELL)fixnum_to_bignum(x),y); \ return OP##_bignum((CELL)fixnum_to_bignum(x),y); \
break; \
default: \ default: \
type_error(FIXNUM_TYPE,y); \ if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(FIXNUM_TYPE,y); \
break; \ break; \
} \ } \
break; \ break; \
default: \ default: \
type_error(FIXNUM_TYPE,y); \ if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(FIXNUM_TYPE,y); \
break; \ break; \
} \ } \
\ \
@ -66,14 +68,13 @@ void primitive_##OP(void) \
switch(TAG(y)) \ switch(TAG(y)) \
{ \ { \
case FIXNUM_TYPE: \ case FIXNUM_TYPE: \
OP##_bignum(x,(CELL)fixnum_to_bignum(y)); \ return OP##_bignum(x,(CELL)fixnum_to_bignum(y)); \
break; \
case OBJECT_TYPE: \ case OBJECT_TYPE: \
\ \
switch(object_type(y)) \ switch(object_type(y)) \
{ \ { \
case BIGNUM_TYPE: \ case BIGNUM_TYPE: \
OP##_bignum(x,y); \ return OP##_bignum(x,y); \
break; \ break; \
default: \ default: \
type_error(BIGNUM_TYPE,y); \ type_error(BIGNUM_TYPE,y); \
@ -81,14 +82,20 @@ void primitive_##OP(void) \
} \ } \
break; \ break; \
default: \ default: \
type_error(BIGNUM_TYPE,y); \ if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(BIGNUM_TYPE,y); \
break; \ break; \
} \ } \
break; \ break; \
\ \
default: \ default: \
\ \
type_error(FIXNUM_TYPE,x); \ if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(FIXNUM_TYPE,x); \
break; \ break; \
} \ } \
\ \
@ -96,13 +103,27 @@ void primitive_##OP(void) \
\ \
default: \ default: \
\ \
type_error(FIXNUM_TYPE,x); \ if(anytype) \
return OP##_anytype(x,y); \
else \
type_error(FIXNUM_TYPE,x); \
break; \ 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); 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_add(void);
void primitive_subtract(void); void primitive_subtract(void);
void primitive_multiply(void); void primitive_multiply(void);

11
native/misc.c
View File

@ -29,3 +29,14 @@ void primitive_millis(void)
dpush(env.dt); dpush(env.dt);
env.dt = tag_object(bignum(t.tv_sec * 1000 + t.tv_usec/1000)); 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_os_env(void);
void primitive_eq(void); void primitive_eq(void);
void primitive_millis(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_set_sbuf_nth, /* 30 */
primitive_sbuf_append, /* 31 */ primitive_sbuf_append, /* 31 */
primitive_sbuf_to_string, /* 32 */ primitive_sbuf_to_string, /* 32 */
primitive_fixnump, /* 33 */ primitive_numberp, /* 33 */
primitive_bignump, /* 34 */ primitive_to_fixnum, /* 34 */
primitive_add, /* 35 */ primitive_to_bignum, /* 35 */
primitive_subtract, /* 36 */ primitive_number_eq, /* 36 */
primitive_multiply, /* 37 */ primitive_fixnump, /* 37 */
primitive_divide, /* 38 */ primitive_bignump, /* 38 */
primitive_mod, /* 39 */ primitive_add, /* 39 */
primitive_divmod, /* 40 */ primitive_subtract, /* 40 */
primitive_and, /* 41 */ primitive_multiply, /* 41 */
primitive_or, /* 42 */ primitive_divide, /* 42 */
primitive_xor, /* 43 */ primitive_mod, /* 43 */
primitive_not, /* 44 */ primitive_divmod, /* 44 */
primitive_shiftleft, /* 45 */ primitive_and, /* 45 */
primitive_shiftright, /* 46 */ primitive_or, /* 46 */
primitive_less, /* 47 */ primitive_xor, /* 47 */
primitive_lesseq, /* 48 */ primitive_not, /* 48 */
primitive_greater, /* 49 */ primitive_shiftleft, /* 49 */
primitive_greatereq, /* 50 */ primitive_shiftright, /* 50 */
primitive_wordp, /* 51 */ primitive_less, /* 51 */
primitive_word, /* 52 */ primitive_lesseq, /* 52 */
primitive_word_primitive, /* 53 */ primitive_greater, /* 53 */
primitive_set_word_primitive, /* 54 */ primitive_greatereq, /* 54 */
primitive_word_parameter, /* 55 */ primitive_wordp, /* 55 */
primitive_set_word_parameter, /* 56 */ primitive_word, /* 56 */
primitive_word_plist, /* 57 */ primitive_word_primitive, /* 57 */
primitive_set_word_plist, /* 58 */ primitive_set_word_primitive, /* 58 */
primitive_drop, /* 59 */ primitive_word_parameter, /* 59 */
primitive_dup, /* 60 */ primitive_set_word_parameter, /* 60 */
primitive_swap, /* 61 */ primitive_word_plist, /* 61 */
primitive_over, /* 62 */ primitive_set_word_plist, /* 62 */
primitive_pick, /* 63 */ primitive_drop, /* 63 */
primitive_nip, /* 64 */ primitive_dup, /* 64 */
primitive_tuck, /* 65 */ primitive_swap, /* 65 */
primitive_rot, /* 66 */ primitive_over, /* 66 */
primitive_to_r, /* 67 */ primitive_pick, /* 67 */
primitive_from_r, /* 68 */ primitive_nip, /* 68 */
primitive_eq, /* 69 */ primitive_tuck, /* 69 */
primitive_getenv, /* 70 */ primitive_rot, /* 70 */
primitive_setenv, /* 71 */ primitive_to_r, /* 71 */
primitive_open_file, /* 72 */ primitive_from_r, /* 72 */
primitive_gc, /* 73 */ primitive_eq, /* 73 */
primitive_save_image, /* 74 */ primitive_getenv, /* 74 */
primitive_datastack, /* 75 */ primitive_setenv, /* 75 */
primitive_callstack, /* 76 */ primitive_open_file, /* 76 */
primitive_set_datastack, /* 77 */ primitive_gc, /* 77 */
primitive_set_callstack, /* 78 */ primitive_save_image, /* 78 */
primitive_handlep, /* 79 */ primitive_datastack, /* 79 */
primitive_exit, /* 80 */ primitive_callstack, /* 80 */
primitive_server_socket, /* 81 */ primitive_set_datastack, /* 81 */
primitive_close_fd, /* 82 */ primitive_set_callstack, /* 82 */
primitive_accept_fd, /* 83 */ primitive_handlep, /* 83 */
primitive_read_line_fd_8, /* 84 */ primitive_exit, /* 84 */
primitive_write_fd_8, /* 85 */ primitive_server_socket, /* 85 */
primitive_flush_fd, /* 86 */ primitive_close_fd, /* 86 */
primitive_shutdown_fd, /* 87 */ primitive_accept_fd, /* 87 */
primitive_room, /* 88 */ primitive_read_line_fd_8, /* 88 */
primitive_os_env, /* 89 */ primitive_write_fd_8, /* 89 */
primitive_millis /* 90 */ 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) CELL primitive_to_xt(CELL primitive)

4
native/primitives.h
View File

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