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

Merge branch 'master' into new_codegen

db4
Slava Pestov 2008-10-21 23:19:20 -05:00
parent 1b06ab1b39 ebd6776fc4
commit 84820244dd
50 changed files with 559 additions and 252 deletions

14
basis/calendar/unix/unix.factor
View File

@ -4,13 +4,19 @@ USING: alien alien.c-types alien.syntax arrays calendar
kernel math unix unix.time namespaces system ;
IN: calendar.unix
: timeval>unix-time ( timeval -- timestamp )
: timeval>seconds ( timeval -- seconds )
[ timeval-sec seconds ] [ timeval-usec microseconds ] bi
time+ since-1970 ;
time+ ;
: timespec>unix-time ( timeval -- timestamp )
: timeval>unix-time ( timeval -- timestamp )
timeval>seconds since-1970 ;
: timespec>seconds ( timespec -- seconds )
[ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
time+ since-1970 ;
time+ ;
: timespec>unix-time ( timespec -- timestamp )
timespec>seconds since-1970 ;
: get-time ( -- alien )
f time <uint> localtime ;

24
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -4,9 +4,9 @@ IN: cpu.x86.assembler.tests
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test
! [ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test
! [ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
! [ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
[ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test
[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 2c HEX: c0 } ] [ [ EAX XMM0 CVTTSD2SI ] { } make ] unit-test
[ { HEX: f2 HEX: 48 HEX: 0f HEX: 2c HEX: c0 } ] [ [ RAX XMM0 CVTTSD2SI ] { } make ] unit-test
@ -39,3 +39,21 @@ IN: cpu.x86.assembler.tests
[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail

19
basis/cpu/x86/assembler/assembler.factor
View File

@ -64,18 +64,18 @@ M: indirect extended? base>> extended? ;
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup base>> { EBP RBP R13 } member? [
dup displacement>> [ 0 >>displacement ] unless
] when ;
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
[ 0 >>displacement ] when ;
: canonicalize-ESP ( indirect -- indirect )
#! { ESP } ==> { ESP ESP }
dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
ERROR: bad-index indirect ;
: check-ESP ( indirect -- indirect )
dup index>> { ESP RSP } memq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
canonicalize-EBP canonicalize-ESP ;
canonicalize-EBP check-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa canonicalize ;
@ -91,7 +91,7 @@ M: indirect extended? base>> extended? ;
GENERIC: sib-present? ( op -- ? )
M: indirect sib-present?
[ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
[ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ;
M: register sib-present? drop f ;
@ -254,7 +254,8 @@ M: object operand-64? drop f ;
reg-code swap addressing ;
: direction-bit ( dst src op -- dst' src' op' )
pick register? [ BIN: 10 opcode-or swapd ] when ;
pick register? pick register? not and
[ BIN: 10 opcode-or swapd ] when ;
: operand-size-bit ( dst src op -- dst' src' op' )
over register-8? [ BIN: 1 opcode-or ] unless ;

8
basis/io/unix/files/files.factor
View File

@ -6,7 +6,7 @@ math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private destructors vocabs.loader calendar.unix
unix.stat alien.c-types arrays unix.users unix.groups
environment fry io.encodings.utf8 alien.strings ;
environment fry io.encodings.utf8 alien.strings unix.statfs ;
IN: io.unix.files
M: unix cwd ( -- path )
@ -142,9 +142,7 @@ os {
[ opendir dup [ (io-error) ] unless ] dip
dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
HOOK: find-next-file os ( DIR* -- byte-array )
M: unix find-next-file ( DIR* -- byte-array )
: find-next-file ( DIR* -- byte-array )
"dirent" <c-object>
f <void*>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
@ -161,8 +159,6 @@ M: unix (directory-entries) ( path -- seq )
[ drop ] produce
] with-unix-directory ;
os openbsd = [ "io.unix.files.openbsd" require ] when
<PRIVATE
: stat-mode ( path -- mode )

1
basis/io/unix/files/openbsd/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

7
basis/io/unix/files/openbsd/openbsd.factor
View File

@ -1,7 +0,0 @@
! Copyright (C) 2005, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: unix system ;
IN: io.unix.files
M: openbsd find-next-file ( DIR* -- byte-array )
readdir ;

15
basis/io/windows/files/files.factor
View File

@ -246,6 +246,21 @@ M: winnt file-info ( path -- info )
M: winnt link-info ( path -- info )
file-info ;
TUPLE: winnt-file-system-info < file-system-info
total-bytes total-free-bytes ;
M: winnt file-system-info ( path -- file-system-info )
normalize-path
dup file-info directory? [ parent-directory ] unless
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep
\ winnt-file-system-info new
swap *ulonglong >>total-free-bytes
swap *ulonglong >>total-bytes
swap *ulonglong >>free-space ;
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-path open-existing &dispose handle>>

25
basis/tools/scaffold/scaffold.factor
View File

@ -16,13 +16,18 @@ ERROR: vocab-name-contains-dot path ;
ERROR: no-vocab vocab ;
<PRIVATE
: root? ( string -- ? )
vocab-roots get member? ;
: root? ( string -- ? ) vocab-roots get member? ;
: length-changes? ( seq quot -- ? )
dupd call [ length ] bi@ = not ; inline
: check-vocab-name ( string -- string )
dup dup [ CHAR: . = ] trim [ length ] bi@ =
[ vocab-name-contains-dot ] unless
dup [ [ CHAR: . = ] trim ] length-changes?
[ vocab-name-contains-dot ] when
".." over subseq? [ vocab-name-contains-dot ] when
dup [ path-separator? ] contains?
[ vocab-name-contains-separator ] when ;
@ -43,8 +48,11 @@ ERROR: no-vocab vocab ;
: scaffolding ( path -- )
"Creating scaffolding for " write <pathname> . ;
: (scaffold-path) ( path string -- path )
dupd [ file-name ] dip append append-path ;
: scaffold-path ( path string -- path ? )
dupd [ file-name ] dip append append-path
(scaffold-path)
dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
: scaffold-copyright ( -- )
@ -205,14 +213,15 @@ ERROR: no-vocab vocab ;
: check-vocab ( vocab -- vocab )
dup find-vocab-root [ no-vocab ] unless ;
PRIVATE>
: link-vocab ( vocab -- )
check-vocab
"Edit documentation: " write
[ find-vocab-root ] keep
[ append-path ] keep "-docs.factor" append append-path
<pathname> . ;
[ find-vocab-root ]
[ vocab>scaffold-path ] bi
"-docs.factor" (scaffold-path) <pathname> . ;
: help. ( word -- )
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;

13
basis/unix/stat/linux/32/32.factor
View File

@ -22,21 +22,8 @@ C-STRUCT: stat
{ "ulong" "unused4" }
{ "ulong" "unused5" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
: stat ( pathname buf -- int ) 3 -rot __xstat ;
: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
C-STRUCT: statfs
{ "long" "f_type" }
{ "long" "f_bsize" }
{ "long" "f_blocks" }
{ "long" "f_bfree" }
{ "long" "f_bavail" }
{ "long" "f_files" }
{ "long" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "long" "f_namelen" } ;

19
basis/unix/stat/linux/64/64.factor
View File

@ -28,22 +28,3 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
: stat ( pathname buf -- int ) 1 -rot __xstat ;
: lstat ( pathname buf -- int ) 1 -rot __lxstat ;
TYPEDEF: ssize_t __SWORD_TYPE
TYPEDEF: ulonglong __fsblkcnt64_t
TYPEDEF: ulonglong __fsfilcnt64_t
C-STRUCT: statfs64
{ "__SWORD_TYPE" "f_type" }
{ "__SWORD_TYPE" "f_bsize" }
{ "__fsblkcnt64_t" "f_blocks" }
{ "__fsblkcnt64_t" "f_bfree" }
{ "__fsblkcnt64_t" "f_bavail" }
{ "__fsfilcnt64_t" "f_files" }
{ "__fsfilcnt64_t" "f_ffree" }
{ "__fsid_t" "f_fsid" }
{ "__SWORD_TYPE" "f_namelen" }
{ "__SWORD_TYPE" "f_frsize" }
{ { "__SWORD_TYPE" 5 } "f_spare" } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;

111
basis/unix/stat/macosx/macosx.factor
View File

@ -31,114 +31,3 @@ FUNCTION: int lstat64 ( char* pathname, stat* buf ) ;
: stat ( path buf -- n ) stat64 ;
: lstat ( path buf -- n ) lstat64 ;
: MNT_RDONLY HEX: 00000001 ; inline
: MNT_SYNCHRONOUS HEX: 00000002 ; inline
: MNT_NOEXEC HEX: 00000004 ; inline
: MNT_NOSUID HEX: 00000008 ; inline
: MNT_NODEV HEX: 00000010 ; inline
: MNT_UNION HEX: 00000020 ; inline
: MNT_ASYNC HEX: 00000040 ; inline
: MNT_EXPORTED HEX: 00000100 ; inline
: MNT_QUARANTINE HEX: 00000400 ; inline
: MNT_LOCAL HEX: 00001000 ; inline
: MNT_QUOTA HEX: 00002000 ; inline
: MNT_ROOTFS HEX: 00004000 ; inline
: MNT_DOVOLFS HEX: 00008000 ; inline
: MNT_DONTBROWSE HEX: 00100000 ; inline
: MNT_IGNORE_OWNERSHIP HEX: 00200000 ; inline
: MNT_AUTOMOUNTED HEX: 00400000 ; inline
: MNT_JOURNALED HEX: 00800000 ; inline
: MNT_NOUSERXATTR HEX: 01000000 ; inline
: MNT_DEFWRITE HEX: 02000000 ; inline
: MNT_MULTILABEL HEX: 04000000 ; inline
: MNT_NOATIME HEX: 10000000 ; inline
: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP ; inline
: MNT_VISFLAGMASK ( -- n )
{
MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
MNT_NOSUID MNT_NODEV MNT_UNION
MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
MNT_LOCAL MNT_QUOTA
MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
} flags ; inline
: MNT_UPDATE HEX: 00010000 ; inline
: MNT_RELOAD HEX: 00040000 ; inline
: MNT_FORCE HEX: 00080000 ; inline
: MNT_CMDFLAGS { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
: VFS_GENERIC 0 ; inline
: VFS_NUMMNTOPS 1 ; inline
: VFS_MAXTYPENUM 1 ; inline
: VFS_CONF 2 ; inline
: VFS_SET_PACKAGE_EXTS 3 ; inline
: MNT_WAIT 1 ; inline
: MNT_NOWAIT 2 ; inline
: VFS_CTL_VERS1 HEX: 01 ; inline
: VFS_CTL_STATFS HEX: 00010001 ; inline
: VFS_CTL_UMOUNT HEX: 00010002 ; inline
: VFS_CTL_QUERY HEX: 00010003 ; inline
: VFS_CTL_NEWADDR HEX: 00010004 ; inline
: VFS_CTL_TIMEO HEX: 00010005 ; inline
: VFS_CTL_NOLOCKS HEX: 00010006 ; inline
C-STRUCT: vfsquery
{ "uint32_t" "vq_flags" }
{ { "uint32_t" 31 } "vq_spare" } ;
: VQ_NOTRESP HEX: 0001 ; inline
: VQ_NEEDAUTH HEX: 0002 ; inline
: VQ_LOWDISK HEX: 0004 ; inline
: VQ_MOUNT HEX: 0008 ; inline
: VQ_UNMOUNT HEX: 0010 ; inline
: VQ_DEAD HEX: 0020 ; inline
: VQ_ASSIST HEX: 0040 ; inline
: VQ_NOTRESPLOCK HEX: 0080 ; inline
: VQ_UPDATE HEX: 0100 ; inline
: VQ_FLAG0200 HEX: 0200 ; inline
: VQ_FLAG0400 HEX: 0400 ; inline
: VQ_FLAG0800 HEX: 0800 ; inline
: VQ_FLAG1000 HEX: 1000 ; inline
: VQ_FLAG2000 HEX: 2000 ; inline
: VQ_FLAG4000 HEX: 4000 ; inline
: VQ_FLAG8000 HEX: 8000 ; inline
: NFSV4_MAX_FH_SIZE 128 ; inline
: NFSV3_MAX_FH_SIZE 64 ; inline
: NFSV2_MAX_FH_SIZE 32 ; inline
: NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE ; inline
: MFSNAMELEN 15 ; inline
: MNAMELEN 90 ; inline
: MFSTYPENAMELEN 16 ; inline
C-STRUCT: fsid_t
{ { "int32_t" 2 } "val" } ;
C-STRUCT: statfs64
{ "uint32_t" "f_bsize" }
{ "int32_t" "f_iosize" }
{ "uint64_t" "f_blocks" }
{ "uint64_t" "f_bfree" }
{ "uint64_t" "f_bavail" }
{ "uint64_t" "f_files" }
{ "uint64_t" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "uid_t" "f_owner" }
{ "uint32_t" "f_type" }
{ "uint32_t" "f_flags" }
{ "uint32_t" "f_fssubtype" }
{ { "char" MFSTYPENAMELEN } "f_fstypename" }
{ { "char" MAXPATHLEN } "f_mntonname" }
{ { "char" MAXPATHLEN } "f_mntfromname" }
{ { "uint32_t" 8 } "f_reserved" } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;

1
basis/unix/statfs/freebsd/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

52
basis/unix/statfs/freebsd/freebsd.factor Normal file
View File

@ -0,0 +1,52 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel unix io.files math accessors
combinators system io.backend alien.c-types ;
IN: unix.statfs.freebsd
: ST_RDONLY 1 ; inline
: ST_NOSUID 2 ; inline
C-STRUCT: statvfs
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_files" }
{ "ulong" "f_bsize" }
{ "ulong" "f_flag" }
{ "ulong" "f_frsize" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
TUPLE: freebsd-file-system-info < file-system-info
bavail bfree blocks favail ffree ffiles
bsize flag frsize fsid namemax ;
M: freebsd >file-system-info ( struct -- statfs )
[ \ freebsd-file-system-info new ] dip
{
[
[ statvfs-f_bsize ]
[ statvfs-f_bavail ] bi * >>free-space
]
[ statvfs-f_bavail >>bavail ]
[ statvfs-f_bfree >>bfree ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_favail >>favail ]
[ statvfs-f_ffree >>ffree ]
[ statvfs-f_files >>files ]
[ statvfs-f_bsize >>bsize ]
[ statvfs-f_flag >>flag ]
[ statvfs-f_frsize >>frsize ]
[ statvfs-f_fsid >>fsid ]
[ statvfs-f_namemax >>namemax ]
} cleave ;
M: freebsd file-system-info ( path -- byte-array )
normalize-path
"statvfs" <c-object> tuck statvfs io-error
>file-system-info ;

0
basis/io/unix/files/openbsd/tags.txt → basis/unix/statfs/freebsd/tags.txt
View File

46
basis/unix/statfs/linux/32/32.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel io.files unix.stat
math accessors system unix io.backend layouts vocabs.loader
alien.syntax ;
IN: unix.statfs.linux
C-STRUCT: statfs
{ "long" "f_type" }
{ "long" "f_bsize" }
{ "long" "f_blocks" }
{ "long" "f_bfree" }
{ "long" "f_bavail" }
{ "long" "f_files" }
{ "long" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "long" "f_namelen" } ;
FUNCTION: int statfs ( char* path, statfs* buf ) ;
TUPLE: linux32-file-system-info < file-system-info
type bsize blocks bfree bavail files ffree fsid
namelen frsize spare ;
M: linux >file-system-info ( struct -- statfs )
[ \ linux32-file-system-info new ] dip
{
[
[ statfs-f_bsize ]
[ statfs-f_bavail ] bi * >>free-space
]
[ statfs-f_type >>type ]
[ statfs-f_bsize >>bsize ]
[ statfs-f_blocks >>blocks ]
[ statfs-f_bfree >>bfree ]
[ statfs-f_bavail >>bavail ]
[ statfs-f_files >>files ]
[ statfs-f_ffree >>ffree ]
[ statfs-f_fsid >>fsid ]
[ statfs-f_namelen >>namelen ]
} cleave ;
M: linux file-system-info ( path -- byte-array )
normalize-path
"statfs" <c-object> tuck statfs io-error
>file-system-info ;

1
basis/unix/statfs/linux/32/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statfs/linux/32/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

50
basis/unix/statfs/linux/64/64.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel io.files unix.stat
math accessors system unix io.backend layouts vocabs.loader
alien.syntax ;
IN: unix.statfs.linux
C-STRUCT: statfs64
{ "__SWORD_TYPE" "f_type" }
{ "__SWORD_TYPE" "f_bsize" }
{ "__fsblkcnt64_t" "f_blocks" }
{ "__fsblkcnt64_t" "f_bfree" }
{ "__fsblkcnt64_t" "f_bavail" }
{ "__fsfilcnt64_t" "f_files" }
{ "__fsfilcnt64_t" "f_ffree" }
{ "__fsid_t" "f_fsid" }
{ "__SWORD_TYPE" "f_namelen" }
{ "__SWORD_TYPE" "f_frsize" }
{ { "__SWORD_TYPE" 5 } "f_spare" } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
TUPLE: linux64-file-system-info < file-system-info
type bsize blocks bfree bavail files ffree fsid
namelen frsize spare ;
M: linux >file-system-info ( struct -- statfs )
[ \ linux64-file-system-info new ] dip
{
[
[ statfs64-f_bsize ]
[ statfs64-f_bavail ] bi * >>free-space
]
[ statfs64-f_type >>type ]
[ statfs64-f_bsize >>bsize ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>bfree ]
[ statfs64-f_bavail >>bavail ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>ffree ]
[ statfs64-f_fsid >>fsid ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>frsize ]
[ statfs64-f_spare >>spare ]
} cleave ;
M: linux file-system-info ( path -- byte-array )
normalize-path
"statfs64" <c-object> tuck statfs64 io-error
>file-system-info ;

1
basis/unix/statfs/linux/64/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statfs/linux/64/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

4
basis/unix/statfs/linux/linux-tests.factor
View File

@ -1,4 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test unix.statfs.linux ;
IN: unix.statfs.linux.tests

34
basis/unix/statfs/linux/linux.factor
View File

@ -1,34 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel io.files unix.stat
math accessors system unix io.backend ;
math accessors system unix io.backend layouts vocabs.loader ;
IN: unix.statfs.linux
TUPLE: linux-file-system-info < file-system-info
type bsize blocks bfree bavail files ffree fsid
namelen frsize spare ;
: statfs>file-system-info ( struct -- statfs )
[ \ linux-file-system-info new ] dip
{
[
[ statfs64-f_bsize ]
[ statfs64-f_bavail ] bi * >>free-space
]
[ statfs64-f_type >>type ]
[ statfs64-f_bsize >>bsize ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>bfree ]
[ statfs64-f_bavail >>bavail ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>ffree ]
[ statfs64-f_fsid >>fsid ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>frsize ]
[ statfs64-f_spare >>spare ]
} cleave ;
M: linux file-system-info ( path -- byte-array )
normalize-path
"statfs64" <c-object> tuck statfs64 io-error
statfs>file-system-info ;
cell-bits {
{ 32 [ "unix.statfs.linux.32" require ] }
{ 64 [ "unix.statfs.linux.64" require ] }
} case

4
basis/unix/statfs/macosx/macosx-tests.factor
View File

@ -1,4 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test unix.statfs.macosx ;
IN: unix.statfs.macosx.tests

119
basis/unix/statfs/macosx/macosx.factor
View File

@ -2,9 +2,122 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system unix.statfs io.files io.backend alien.strings ;
grouping system unix.statfs io.files io.backend alien.strings
math.bitwise alien.syntax ;
IN: unix.statfs.macosx
: MNT_RDONLY HEX: 00000001 ; inline
: MNT_SYNCHRONOUS HEX: 00000002 ; inline
: MNT_NOEXEC HEX: 00000004 ; inline
: MNT_NOSUID HEX: 00000008 ; inline
: MNT_NODEV HEX: 00000010 ; inline
: MNT_UNION HEX: 00000020 ; inline
: MNT_ASYNC HEX: 00000040 ; inline
: MNT_EXPORTED HEX: 00000100 ; inline
: MNT_QUARANTINE HEX: 00000400 ; inline
: MNT_LOCAL HEX: 00001000 ; inline
: MNT_QUOTA HEX: 00002000 ; inline
: MNT_ROOTFS HEX: 00004000 ; inline
: MNT_DOVOLFS HEX: 00008000 ; inline
: MNT_DONTBROWSE HEX: 00100000 ; inline
: MNT_IGNORE_OWNERSHIP HEX: 00200000 ; inline
: MNT_AUTOMOUNTED HEX: 00400000 ; inline
: MNT_JOURNALED HEX: 00800000 ; inline
: MNT_NOUSERXATTR HEX: 01000000 ; inline
: MNT_DEFWRITE HEX: 02000000 ; inline
: MNT_MULTILABEL HEX: 04000000 ; inline
: MNT_NOATIME HEX: 10000000 ; inline
: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP ; inline
: MNT_VISFLAGMASK ( -- n )
{
MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
MNT_NOSUID MNT_NODEV MNT_UNION
MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
MNT_LOCAL MNT_QUOTA
MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
} flags ; inline
: MNT_UPDATE HEX: 00010000 ; inline
: MNT_RELOAD HEX: 00040000 ; inline
: MNT_FORCE HEX: 00080000 ; inline
: MNT_CMDFLAGS { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
: VFS_GENERIC 0 ; inline
: VFS_NUMMNTOPS 1 ; inline
: VFS_MAXTYPENUM 1 ; inline
: VFS_CONF 2 ; inline
: VFS_SET_PACKAGE_EXTS 3 ; inline
: MNT_WAIT 1 ; inline
: MNT_NOWAIT 2 ; inline
: VFS_CTL_VERS1 HEX: 01 ; inline
: VFS_CTL_STATFS HEX: 00010001 ; inline
: VFS_CTL_UMOUNT HEX: 00010002 ; inline
: VFS_CTL_QUERY HEX: 00010003 ; inline
: VFS_CTL_NEWADDR HEX: 00010004 ; inline
: VFS_CTL_TIMEO HEX: 00010005 ; inline
: VFS_CTL_NOLOCKS HEX: 00010006 ; inline
C-STRUCT: vfsquery
{ "uint32_t" "vq_flags" }
{ { "uint32_t" 31 } "vq_spare" } ;
: VQ_NOTRESP HEX: 0001 ; inline
: VQ_NEEDAUTH HEX: 0002 ; inline
: VQ_LOWDISK HEX: 0004 ; inline
: VQ_MOUNT HEX: 0008 ; inline
: VQ_UNMOUNT HEX: 0010 ; inline
: VQ_DEAD HEX: 0020 ; inline
: VQ_ASSIST HEX: 0040 ; inline
: VQ_NOTRESPLOCK HEX: 0080 ; inline
: VQ_UPDATE HEX: 0100 ; inline
: VQ_FLAG0200 HEX: 0200 ; inline
: VQ_FLAG0400 HEX: 0400 ; inline
: VQ_FLAG0800 HEX: 0800 ; inline
: VQ_FLAG1000 HEX: 1000 ; inline
: VQ_FLAG2000 HEX: 2000 ; inline
: VQ_FLAG4000 HEX: 4000 ; inline
: VQ_FLAG8000 HEX: 8000 ; inline
: NFSV4_MAX_FH_SIZE 128 ; inline
: NFSV3_MAX_FH_SIZE 64 ; inline
: NFSV2_MAX_FH_SIZE 32 ; inline
: NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE ; inline
: MFSNAMELEN 15 ; inline
: MNAMELEN 90 ; inline
: MFSTYPENAMELEN 16 ; inline
C-STRUCT: fsid_t
{ { "int32_t" 2 } "val" } ;
C-STRUCT: statfs64
{ "uint32_t" "f_bsize" }
{ "int32_t" "f_iosize" }
{ "uint64_t" "f_blocks" }
{ "uint64_t" "f_bfree" }
{ "uint64_t" "f_bavail" }
{ "uint64_t" "f_files" }
{ "uint64_t" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "uid_t" "f_owner" }
{ "uint32_t" "f_type" }
{ "uint32_t" "f_flags" }
{ "uint32_t" "f_fssubtype" }
{ { "char" MFSTYPENAMELEN } "f_fstypename" }
{ { "char" MAXPATHLEN } "f_mntonname" }
{ { "char" MAXPATHLEN } "f_mntfromname" }
{ { "uint32_t" 8 } "f_reserved" } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;
TUPLE: macosx-file-system-info < file-system-info
block-size io-size blocks blocks-free blocks-available files
files-free file-system-id owner type flags filesystem-subtype
@ -15,7 +128,7 @@ M: macosx mounted* ( -- array )
[ *void* ] dip
"statfs64" heap-size [ * memory>byte-array ] keep group ;
: statfs64>file-system-info ( byte-array -- file-system-info )
M: macosx >file-system-info ( byte-array -- file-system-info )
[ \ macosx-file-system-info new ] dip
{
[
@ -49,4 +162,4 @@ M: macosx mounted* ( -- array )
M: macosx file-system-info ( path -- file-system-info )
normalize-path
"statfs64" <c-object> tuck statfs64 io-error
statfs64>file-system-info ;
>file-system-info ;

8
basis/unix/statfs/netbsd/netbsd.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel io.files unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings ;
io.encodings.utf8 alien.strings unix.types ;
IN: unix.statfs.netbsd
: _VFS_NAMELEN 32 ; inline
@ -34,6 +34,8 @@ C-STRUCT: statvfs
{ { "char" _VFS_NAMELEN } "f_mntonname" }
{ { "char" _VFS_NAMELEN } "f_mntfromname" } ;
FUNCTION: int statvfs ( char* path, statvfs *buf ) ;
TUPLE: netbsd-file-system-info < file-system-info
flag bsize frsize io-size
blocks blocks-free blocks-available blocks-reserved
@ -41,7 +43,7 @@ files ffree sync-reads sync-writes async-reads async-writes
fsidx fsid namemax owner spare fstype mnotonname mntfromname
file-system-type-name mount-from ;
: statvfs>file-system-info ( byte-array -- netbsd-file-system-info )
M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info )
[ \ netbsd-file-system-info new ] dip
{
[
@ -73,4 +75,4 @@ file-system-type-name mount-from ;
M: netbsd file-system-info
normalize-path "statvfs" <c-object> tuck statvfs io-error
statvfs>file-system-info ;
>file-system-info ;

26
basis/unix/statfs/openbsd/32/32.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel unix ;
IN: unix.statfs.openbsd.32
: MFSNAMELEN 16 ; inline
: MNAMELEN 90 ; inline
C-STRUCT: statfs
{ "u_int32_t" "f_flags" }
{ "int32_t" "f_bsize" }
{ "u_int32_t" "f_iosize" }
{ "u_int32_t" "f_blocks" }
{ "u_int32_t" "f_bfree" }
{ "int32_t" "f_bavail" }
{ "u_int32_t" "f_files" }
{ "u_int32_t" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "uid_t" "f_owner" }
{ "u_int32_t" "f_syncwrites" }
{ "u_int32_t" "f_asyncwrites" }
{ "u_int32_t" "f_ctime" }
{ { "u_int32_t" 3 } "f_spare" }
{ { "char" MFSNAMELEN } "f_fstypename" }
{ { "char" MNAMELEN } "f_mntonname" }
{ { "char" MNAMELEN } "f_mntfromname" } ;

1
basis/unix/statfs/openbsd/32/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statfs/openbsd/32/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

32
basis/unix/statfs/openbsd/64/64.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax unix ;
IN: unix.statfs.openbsd.64
: MFSNAMELEN 16 ; inline
: MNAMELEN 90 ; inline
C-STRUCT: statfss
{ "u_int32_t" "f_flags" }
{ "u_int32_t" "f_bsize" }
{ "u_int32_t" "f_iosize" }
{ "u_int64_t" "f_blocks" }
{ "u_int64_t" "f_bfree" }
{ "int64_t" "f_bavail" }
{ "u_int64_t" "f_files" }
{ "u_int64_t" "f_ffree" }
{ "int64_t" "f_favail" }
{ "u_int64_t" "f_syncwrites" }
{ "u_int64_t" "f_syncreads" }
{ "u_int64_t" "f_asyncwrites" }
{ "u_int64_t" "f_asyncreads" }
{ "fsid_t" "f_fsid" }
{ "u_int32_t" "f_namemax" }
{ "uid_t" "f_owner" }
{ "u_int32_t" "f_ctime" }
{ { "u_int32_t" 3 } " f_spare" }
{ { "char" MFSNAMELEN } "f_fstypename" }
{ { "char" MNAMELEN } "f_mntonname" }
{ { "char" MNAMELEN } "f_mntfromname" }
{ { "char" 512 } "mount_info" } ;
! { "mount_info" "mount_info" } ;

1
basis/unix/statfs/openbsd/64/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statfs/openbsd/64/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/unix/statfs/openbsd/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

52
basis/unix/statfs/openbsd/openbsd.factor Normal file
View File

@ -0,0 +1,52 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax accessors combinators kernel io.files
unix.types math system io.backend alien.c-types unix ;
IN: unix.statfs.openbsd
C-STRUCT: statvfs
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "ulong" "f_fsid" }
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" } ;
: ST_RDONLY 1 ; inline
: ST_NOSUID 2 ; inline
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
TUPLE: openbsd-file-system-info < file-system-info
bsize frsize blocks bfree bavail files ffree favail
fsid flag namemax ;
M: openbsd >file-system-info ( struct -- statfs )
[ \ openbsd-file-system-info new ] dip
{
[
[ statvfs-f_bsize ]
[ statvfs-f_bavail ] bi * >>free-space
]
[ statvfs-f_bsize >>bsize ]
[ statvfs-f_frsize >>frsize ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_bfree >>bfree ]
[ statvfs-f_bavail >>bavail ]
[ statvfs-f_files >>files ]
[ statvfs-f_ffree >>ffree ]
[ statvfs-f_favail >>favail ]
[ statvfs-f_fsid >>fsid ]
[ statvfs-f_flag >>flag ]
[ statvfs-f_namemax >>namemax ]
} cleave ;
M: openbsd file-system-info ( path -- byte-array )
normalize-path
"statvfs" <c-object> tuck statvfs io-error
>file-system-info ;

1
basis/unix/statfs/openbsd/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

6
basis/unix/statfs/statfs.factor
View File

@ -25,7 +25,7 @@ TUPLE: file-system-info root-directory total-free-size total-size ;
os {
{ linux [ "unix.statfs.linux" require ] }
{ macosx [ "unix.statfs.macosx" require ] }
! { freebsd [ "unix.statfs.freebsd" require ] }
! { netbsd [ "unix.statfs.netbsd" require ] }
! { openbsd [ "unix.statfs.openbsd" require ] }
{ freebsd [ "unix.statfs.freebsd" require ] }
{ netbsd [ "unix.statfs.netbsd" require ] }
{ openbsd [ "unix.statfs.openbsd" require ] }
} case

4
basis/unix/types/linux/linux.factor
View File

@ -23,3 +23,7 @@ TYPEDEF: __slongword_type blkcnt_t
TYPEDEF: __sword_type ssize_t
TYPEDEF: __s32_type pid_t
TYPEDEF: __slongword_type time_t
TYPEDEF: ssize_t __SWORD_TYPE
TYPEDEF: ulonglong __fsblkcnt64_t
TYPEDEF: ulonglong __fsfilcnt64_t

6
basis/unix/types/netbsd/netbsd.factor
View File

@ -17,12 +17,6 @@ TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
TYPEDEF: __uint64_t fsblkcnt_t
TYPEDEF: fsblkcnt_t __fsblkcnt_t
TYPEDEF: __uint64_t fsfilcnt_t
TYPEDEF: fsfilcnt_t __fsfilcnt_t
cell-bits {
{ 32 [ "unix.types.netbsd.32" require ] }
{ 64 [ "unix.types.netbsd.64" require ] }

5
basis/unix/types/types.factor
View File

@ -6,6 +6,11 @@ TYPEDEF: void* caddr_t
TYPEDEF: uint in_addr_t
TYPEDEF: uint socklen_t
TYPEDEF: __uint64_t fsblkcnt_t
TYPEDEF: fsblkcnt_t __fsblkcnt_t
TYPEDEF: __uint64_t fsfilcnt_t
TYPEDEF: fsfilcnt_t __fsfilcnt_t
TYPEDEF: char int8_t
TYPEDEF: short int16_t
TYPEDEF: int int32_t

3
basis/windows/kernel32/kernel32.factor
View File

@ -928,7 +928,8 @@ FUNCTION: HANDLE GetCurrentThread ( ) ;
! FUNCTION: GetDevicePowerState
! FUNCTION: GetDiskFreeSpaceA
! FUNCTION: GetDiskFreeSpaceExA
! FUNCTION: GetDiskFreeSpaceExW
FUNCTION: BOOL GetDiskFreeSpaceExW ( LPCTSTR lpDirectoryName, PULARGE_INTEGER pFreeBytesAvailable, PULARGE_INTEGER lpTotalNumberOfBytes, PULARGE_INTEGER lpTotalNumberOfFreeBytes ) ;
ALIAS: GetDiskFreeSpaceEx GetDiskFreeSpaceExW
! FUNCTION: GetDiskFreeSpaceW
! FUNCTION: GetDllDirectoryA
! FUNCTION: GetDllDirectoryW

2
basis/windows/types/types.factor
View File

@ -62,7 +62,9 @@ TYPEDEF: ulonglong ULONGLONG
TYPEDEF: longlong LONG64
TYPEDEF: ulonglong DWORD64
TYPEDEF: longlong LARGE_INTEGER
TYPEDEF: ulonglong ULARGE_INTEGER
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR

7
core/io/files/files-docs.factor
View File

@ -81,6 +81,7 @@ ARTICLE: "fs-meta" "File metadata"
{ $subsection link-info }
{ $subsection exists? }
{ $subsection directory? }
"File types:"
{ $subsection "file-types" } ;
@ -322,6 +323,12 @@ HELP: with-directory-files
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
HELP: file-system-info
{ $values
{ "path" "a pathname string" }
{ "file-system-info" file-system-info } }
{ $description "Returns a platform-specific object describing the file-system that contains the path. The cross-platform slot is " { $slot "free-space" } "." } ;
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
{ $description "Resolve a path relative to the Factor source code location." } ;

3
core/io/files/files.factor
View File

@ -188,6 +188,9 @@ TUPLE: file-system-info mount-on free-space ;
HOOK: file-system-info os ( path -- file-system-info )
HOOK: >file-system-info os ( struct -- statfs )
<PRIVATE
HOOK: cd io-backend ( path -- )

6
extra/hexdump/hexdump-docs.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
USING: help.markup help.syntax kernel sequences strings ;
IN: hexdump
HELP: hexdump.
{ $values { "sequence" "a sequence" } }
{ $values { "seq" sequence } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
HELP: hexdump
{ $values { "sequence" "a sequence" } { "string" "a string" } }
{ $values { "seq" sequence } { "str" string } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
{ $see-also hexdump. } ;

25
extra/hexdump/hexdump.factor
View File

@ -7,29 +7,30 @@ IN: hexdump
<PRIVATE
: header. ( len -- )
"Length: " write dup unparse write ", " write >hex write "h" write nl ;
: write-header ( len -- )
"Length: " write
[ unparse write ", " write ]
[ >hex write "h" write nl ] bi ;
: offset. ( lineno -- )
: write-offset ( lineno -- )
16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
: h-pad. ( digit -- )
: write-hex-digit ( digit -- )
>hex 2 CHAR: 0 pad-left write ;
: line. ( str n -- )
offset.
dup [ h-pad. " " write ] each
: write-hex-line ( str n -- )
write-offset
dup [ write-hex-digit bl ] each
16 over length - 3 * CHAR: \s <string> write
[ dup printable? [ drop CHAR: . ] unless write1 ] each
nl ;
PRIVATE>
: hexdump ( sequence -- string )
: hexdump ( seq -- str )
[
dup length header.
16 <sliced-groups> [ line. ] each-index
[ length write-header ]
[ 16 <sliced-groups> [ write-hex-line ] each-index ] bi
] with-string-writer ;
: hexdump. ( sequence -- )
hexdump write ;
: hexdump. ( seq -- ) hexdump write ;

1
extra/math/floating-point/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

4
basis/unix/statfs/netbsd/netbsd-tests.factor → extra/math/floating-point/floating-point-tests.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test unix.statfs.netbsd ;
IN: unix.statfs.netbsd.tests
USING: tools.test math.floating-point ;
IN: math.floating-point.tests

32
extra/math/floating-point/floating-point.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences ;
IN: math.floating-point
: float-sign ( float -- ? )
float>bits -31 shift { 1 -1 } nth ;
: double-sign ( float -- ? )
double>bits -63 shift { 1 -1 } nth ;
: float-exponent-bits ( float -- n )
float>bits -23 shift 8 2^ 1- bitand ;
: double-exponent-bits ( double -- n )
double>bits -52 shift 11 2^ 1- bitand ;
: float-mantissa-bits ( float -- n )
float>bits 23 2^ 1- bitand ;
: double-mantissa-bits ( double -- n )
double>bits 52 2^ 1- bitand ;
: float-e ( -- float ) 127 ; inline
: double-e ( -- float ) 1023 ; inline
! : calculate-float ( S M E -- float )
! float-e - 2^ * * ; ! bits>float ;
! : calculate-double ( S M E -- frac )
! double-e - 2^ swap 52 2^ /f 1+ * * ;

3
extra/roman/roman-docs.factor
View File

@ -43,3 +43,6 @@ HELP: roman/mod
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
{ $see-also roman* roman/i /mod } ;
HELP: ROMAN:
{ $description "A parsing word that reads the next token and converts it to an integer." } ;

2
extra/roman/roman-tests.factor
View File

@ -36,3 +36,5 @@ USING: arrays kernel math roman roman.private sequences tools.test ;
[ "i" ] [ "iii" "ii" roman/i ] unit-test
[ "i" "ii" ] [ "v" "iii" roman/mod ] unit-test
[ "iii" "iii" roman- ] must-fail
[ 30 ] [ ROMAN: xxx ] unit-test

8
extra/roman/roman.factor
View File

@ -2,10 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.order math.vectors
namespaces make quotations sequences sequences.lib
sequences.private strings unicode.case ;
sequences.private strings unicode.case lexer parser ;
IN: roman
<PRIVATE
: roman-digits ( -- seq )
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
@ -34,6 +35,7 @@ ERROR: roman-range-error n ;
] [
first2 swap -
] if ;
PRIVATE>
: >roman ( n -- str )
@ -49,11 +51,13 @@ PRIVATE>
] map sum ;
<PRIVATE
: 2roman> ( str1 str2 -- m n )
[ roman> ] bi@ ;
: binary-roman-op ( str1 str2 quot -- str3 )
>r 2roman> r> call >roman ; inline
PRIVATE>
: roman+ ( str1 str2 -- str3 )
@ -70,3 +74,5 @@ PRIVATE>
: roman/mod ( str1 str2 -- str3 str4 )
[ /mod ] binary-roman-op >r >roman r> ;
: ROMAN: scan roman> parsed ; parsing