diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index ddeeb3d8bc..b239d07f46 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -6,6 +6,7 @@ http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup +- fix ceiling - single-stepper and variable access: wrong namespace? - investigate if COPYING_GEN needs a fix - faster layout diff --git a/doc/handbook.tex b/doc/handbook.tex index 86f0040297..56f4db71aa 100644 --- a/doc/handbook.tex +++ b/doc/handbook.tex @@ -861,7 +861,7 @@ Push the current call frame on the call stack, and set the call stack to the giv \textbf{12} \end{alltt} \wordtable{ -\vocabulary{kernel} +\vocabulary{words} \ordinaryword{execute}{execute ( word -- )} } Execute a word definition, taking action based on the word definition, as above. diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 17663905a6..983a370b75 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -298,17 +298,9 @@ M: hashtable ' ( hashtable -- pointer ) : write-word ( word -- ) "64-bits" get [ - "big-endian" get [ - write-big-endian-64 - ] [ - write-little-endian-64 - ] ifte + "big-endian" get [ write-be64 ] [ write-le64 ] ifte ] [ - "big-endian" get [ - write-big-endian-32 - ] [ - write-little-endian-32 - ] ifte + "big-endian" get [ write-be32 ] [ write-le32 ] ifte ] ifte ; : write-image ( image file -- ) diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index b95aeaeaeb..d955aa231f 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -54,6 +54,8 @@ vocabularies get [ [ "(fraction>)" "math-internals" [ [ integer integer ] [ rational ] ] ] [ "str>float" "parser" [ [ string ] [ float ] ] ] [ "(unparse-float)" "unparser" [ [ float ] [ string ] ] ] + [ "float-bits" "math" [ [ real ] [ integer ] ] ] + [ "double-bits" "math" [ [ real ] [ integer ] ] ] [ "" "math-internals" [ [ real real ] [ number ] ] ] [ "fixnum+" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ] [ "fixnum-" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ] diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 8df83a38ac..f1888676bd 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -102,11 +102,13 @@ M: object contains? ( obj seq -- ? ) #! Return a new sequence of the same type as s1. rot [ [ rot nappend ] keep swap nappend ] immutable ; -: concat ( seq -- seq ) - #! Append together a sequence of sequences. - dup empty? [ - unswons [ swap [ nappend ] each-with ] immutable - ] unless ; +M: f concat ; + +M: cons concat + unswons [ swap [ nappend ] each-with ] immutable ; + +M: object concat + >list concat ; M: object peek ( sequence -- element ) #! Get value at end of sequence. diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index a0631c8bfa..b7a616edb7 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -24,6 +24,7 @@ GENERIC: peek ( seq -- elt ) GENERIC: contains? ( elt seq -- ? ) GENERIC: head ( n seq -- seq ) GENERIC: tail ( n seq -- seq ) +GENERIC: concat ( seq -- seq ) G: each ( seq quot -- | quot: elt -- ) [ over ] [ type ] ; inline diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor index 4dab533b8d..bc47c06d80 100644 --- a/library/compiler/ppc/assembler.factor +++ b/library/compiler/ppc/assembler.factor @@ -37,29 +37,98 @@ USING: compiler errors kernel math memory words ; >r 1 shift >r 10 shift >r 11 shift >r 16 shift >r 21 shift r> bitor r> bitor r> bitor r> bitor r> bitor ; -: ADDI d-form 14 insn ; -: LI 0 rot ADDI ; -: ADDIS d-form 15 insn ; -: LIS 0 rot ADDIS ; -: ADD 0 266 0 xo-form 31 insn ; -: SUBI neg ADDI ; +: ADDI d-form 14 insn ; : LI 0 rot ADDI ; : SUBI neg ADDI ; +: ADDIS d-form 15 insn ; : LIS 0 rot ADDIS ; + +: ADDIC d-form 12 insn ; : SUBIC neg ADDIC ; + +: ADDIC. d-form 13 insn ; : SUBIC. neg ADDIC. ; + +: (ADD) 266 swap xo-form 31 insn ; +: ADD 0 0 (ADD) ; +: ADD. 0 1 (ADD) ; +: ADDO 1 0 (ADD) ; +: ADDO. 1 1 (ADD) ; + +: (ADDC) 10 swap xo-form 31 insn ; +: ADDC 0 0 (ADDC) ; +: ADDC. 0 1 (ADDC) ; +: ADDCO 1 0 (ADDC) ; +: ADDCO. 1 1 (ADDC) ; + +: (ADDE) 138 swap xo-form 31 insn ; +: ADDE 0 0 (ADDE) ; +: ADDE. 0 1 (ADDE) ; +: ADDEO 1 0 (ADDE) ; +: ADDEO. 1 1 (ADDE) ; + +: ANDI d-form 28 insn ; +: ANDIS d-form 29 insn ; + +: (AND) 31 swap x-form 31 insn ; +: AND 0 (AND) ; +: AND. 0 (AND) ; + +: (DIVW) 491 swap xo-form 31 insn ; +: DIVW 0 0 (DIVW) ; +: DIVW. 0 1 (DIVW) ; +: DIVWO 1 0 (DIVW) ; +: DIVWO 1 1 (DIVW) ; + +: (DIVWU) 459 swap xo-form 31 insn ; +: DIVWU 0 0 (DIVWU) ; +: DIVWU. 0 1 (DIVWU) ; +: DIVWUO 1 0 (DIVWU) ; +: DIVWUO. 1 1 (DIVWU) ; + +: (EQV) 284 swap x-form 31 insn ; +: EQV 0 (EQV) ; +: EQV. 1 (EQV) ; + +: (NAND) 476 swap x-form 31 insn ; +: NAND 0 (NAND) ; +: NAND. 1 (NAND) ; + +: (NOR) 124 swap x-form 31 insn ; +: NOR 0 (NOR) ; +: NOR. 1 (NOR) ; + : ORI d-form 24 insn ; +: ORIS d-form 25 insn ; + +: (OR) 444 swap x-form 31 insn ; +: OR 0 (OR) ; +: OR. 1 (OR) ; + +: (ORC) 412 swap x-form 31 insn ; +: ORC 0 (ORC) ; +: ORC. 1 (ORC) ; + +: XORI d-form 26 insn ; +: XORIS d-form 27 insn ; + +: (XOR) 316 swap x-form 31 insn ; +: XOR 0 (XOR) ; +: XOR. 1 (XOR) ; + : SRAWI 824 0 x-form 31 insn ; -GENERIC: BL -M: integer BL 0 1 i-form 18 insn ; -M: word BL 0 BL relative-24 ; +: LWZ d-form 32 insn ; +: STW d-form 36 insn ; +: STWU d-form 37 insn ; -GENERIC: B -M: integer B 0 0 i-form 18 insn ; -M: word B 0 B relative-24 ; +G: (B) ( dest aa lk -- ) [ pick ] [ type ] ; +M: integer (B) i-form 18 insn ; +M: word (B) 0 -rot (B) relative-24 ; + +: B 0 0 (B) ; : BA 1 0 (B) ; : BL 0 1 (B) ; : BLA 1 1 (B) ; GENERIC: BC M: integer BC 0 0 b-form 16 insn ; M: word BC >r 0 BC r> relative-14 ; -: BEQ 12 2 rot BC ; -: BNE 4 2 rot BC ; +: BEQ 12 2 rot BC ; : BNE 4 2 rot BC ; + : BCLR 0 8 0 0 b-form 19 insn ; : BLR 20 BCLR ; : BCLRL 0 8 0 1 b-form 19 insn ; @@ -72,9 +141,6 @@ M: word BC >r 0 BC r> relative-14 ; : MTSPR 5 shift 467 xfx-form 31 insn ; : MTLR 8 MTSPR ; : MTCTR 9 MTSPR ; -: LWZ d-form 32 insn ; -: STW d-form 36 insn ; -: STWU d-form 37 insn ; : CMPI d-form 11 insn ; : LOAD32 >r w>h/h r> tuck LIS dup rot ORI ; diff --git a/library/compiler/ppc/slots.factor b/library/compiler/ppc/slots.factor new file mode 100644 index 0000000000..1714f53742 --- /dev/null +++ b/library/compiler/ppc/slots.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: compiler-backend +USING: alien assembler compiler inference kernel +kernel-internals lists math memory namespaces sequences words ; + +: userenv ( vreg -- ) + #! Load the userenv pointer in a virtual register. + v>operand "userenv" f dlsym swap LOAD32 0 1 rel-userenv ; + +M: %getenv generate-node ( vop -- ) + dup vop-out-1 v>operand swap vop-in-1 + [ userenv@ unit MOV ] keep 0 rel-userenv ; + +M: %setenv generate-node ( vop -- ) + dup vop-in-2 + [ userenv@ unit swap vop-in-1 v>operand MOV ] keep + 0 rel-userenv ; diff --git a/library/compiler/ppc/stack.factor b/library/compiler/ppc/stack.factor index 61d4114192..0e8cf116f6 100644 --- a/library/compiler/ppc/stack.factor +++ b/library/compiler/ppc/stack.factor @@ -32,4 +32,4 @@ M: %peek-r generate-node ( vop -- ) dup vop-out-1 v>operand swap vop-in-1 cs-op LWZ ; M: %replace-r generate-node ( vop -- ) - dup vop-in-2 v>operand swap vop-in-2 cs-op STW ; + dup vop-in-2 v>operand swap vop-in-1 cs-op STW ; diff --git a/library/io/stdio-binary.factor b/library/io/stdio-binary.factor index 808f06824c..a655ca4bf7 100644 --- a/library/io/stdio-binary.factor +++ b/library/io/stdio-binary.factor @@ -3,13 +3,13 @@ IN: stdio USING: kernel math ; -: read-little-endian-32 ( -- word ) +: read-le32 ( -- word ) read1 read1 8 shift bitor read1 16 shift bitor read1 24 shift bitor ; -: read-big-endian-32 ( -- word ) +: read-be32 ( -- word ) read1 24 shift read1 16 shift bitor read1 8 shift bitor @@ -24,7 +24,7 @@ USING: kernel math ; : byte1 ( num -- byte ) -8 shift HEX: ff bitand ; : byte0 ( num -- byte ) HEX: ff bitand ; -: write-little-endian-64 ( word -- ) +: write-le64 ( word -- ) dup byte0 write dup byte1 write dup byte2 write @@ -34,7 +34,7 @@ USING: kernel math ; dup byte6 write byte7 write ; -: write-big-endian-64 ( word -- ) +: write-be64 ( word -- ) dup byte7 write dup byte6 write dup byte5 write @@ -44,22 +44,22 @@ USING: kernel math ; dup byte1 write byte0 write ; -: write-little-endian-32 ( word -- ) +: write-le32 ( word -- ) dup byte0 write dup byte1 write dup byte2 write byte3 write ; -: write-big-endian-32 ( word -- ) +: write-be32 ( word -- ) dup byte3 write dup byte2 write dup byte1 write byte0 write ; -: write-little-endian-16 ( char -- ) +: write-le16 ( char -- ) dup byte0 write byte1 write ; -: write-big-endian-16 ( char -- ) +: write-be16 ( char -- ) dup byte1 write byte0 write ; diff --git a/library/math/ratio.factor b/library/math/ratio.factor index 609a6fd0d9..7bee471c5a 100644 --- a/library/math/ratio.factor +++ b/library/math/ratio.factor @@ -40,5 +40,5 @@ M: ratio /i scale /i ; M: ratio /f scale /f ; M: ratio truncate >fraction /i ; -M: ratio floor >fraction /i dup 0 < [ 1 - ] when ; -M: ratio ceiling >fraction /i dup 0 > [ 1 + ] when ; +M: ratio floor [ truncate ] keep 0 < [ 1 - ] when ; +M: ratio ceiling [ truncate ] keep 0 > [ 1 + ] when ; diff --git a/library/test/image.factor b/library/test/image.factor index 1a8c668201..16d120ebfc 100644 --- a/library/test/image.factor +++ b/library/test/image.factor @@ -23,7 +23,7 @@ USE: math [ "\0\0\0\0\u000f\u000e\r\u000c" ] [ - [ image-magic write-big-endian-64 ] with-string + [ image-magic write-be64 ] with-string ] unit-test [ diff --git a/library/test/math/integer.factor b/library/test/math/integer.factor index d1026aaf28..3bcf7b70a5 100644 --- a/library/test/math/integer.factor +++ b/library/test/math/integer.factor @@ -87,3 +87,8 @@ unit-test [ f ] [ 123 power-of-2? ] unit-test [ 8 ] [ 256 log2 ] unit-test [ 0 ] [ 1 log2 ] unit-test + +[ 1 ] [ 7/8 ceiling ] unit-test +[ 2 ] [ 3/2 ceiling ] unit-test +[ 0 ] [ -7/8 ceiling ] unit-test +[ -1 ] [ -3/2 ceiling ] unit-test diff --git a/library/tools/jedit-wire.factor b/library/tools/jedit-wire.factor index 06bf682bb9..a97de1d4be 100644 --- a/library/tools/jedit-wire.factor +++ b/library/tools/jedit-wire.factor @@ -14,10 +14,10 @@ prettyprint sequences stdio streams strings words ; ! captured with with-string. : write-packet ( string -- ) - dup length write-big-endian-32 write flush ; + dup length write-be32 write flush ; : read-packet ( -- string ) - read-big-endian-32 read ; + read-be32 read ; : wire-server ( -- ) #! Repeatedly read jEdit requests and execute them. Return @@ -40,15 +40,13 @@ prettyprint sequences stdio streams strings words ; : jedit-write-attr ( str style -- ) CHAR: w write [ swap . . ] with-string - dup length write-big-endian-32 + dup length write-be32 write ; TUPLE: jedit-stream ; M: jedit-stream stream-readln ( stream -- str ) - [ - CHAR: r write flush read-big-endian-32 read - ] with-wrapper ; + [ CHAR: r write flush read-be32 read ] with-wrapper ; M: jedit-stream stream-write-attr ( str style stream -- ) [ jedit-write-attr ] with-wrapper ; diff --git a/library/tools/jedit.factor b/library/tools/jedit.factor index f840c38d9d..4e56edf1aa 100644 --- a/library/tools/jedit.factor +++ b/library/tools/jedit.factor @@ -25,8 +25,8 @@ streams strings unparser words ; : send-jedit-request ( request -- ) jedit-server-info swap "localhost" swap [ - write-big-endian-32 - dup length write-big-endian-16 + write-be32 + dup length write-be16 write flush ] with-stream ; diff --git a/native/float.c b/native/float.c index 4bba27a313..3affb9bb52 100644 --- a/native/float.c +++ b/native/float.c @@ -197,6 +197,21 @@ void primitive_fsqrt(void) drepl(tag_float(sqrt(to_float(dpeek())))); } +void primitive_float_bits(void) +{ + double x = to_float(dpeek()); + float x_ = (float)x; + CELL x_bits = *(CELL*)(&x_); + drepl(tag_cell(x_bits)); +} + +void primitive_double_bits(void) +{ + double x = to_float(dpeek()); + u64 x_bits = *(u64*)(&x); + drepl(tag_bignum(s48_long_long_to_bignum(x_bits))); +} + #define DEFBOX(name,type) \ void name (type flo) \ { \ diff --git a/native/float.h b/native/float.h index 255bb2523e..fd62b25c27 100644 --- a/native/float.h +++ b/native/float.h @@ -49,6 +49,9 @@ void primitive_fsin(void); void primitive_fsinh(void); void primitive_fsqrt(void); +void primitive_float_bits(void); +void primitive_double_bits(void); + void box_float(float flo); float unbox_float(void); void box_double(double flo); diff --git a/native/primitives.c b/native/primitives.c index 8550fe82ad..6cb10f4d6d 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -20,6 +20,8 @@ void* primitives[] = { primitive_from_fraction, primitive_str_to_float, primitive_float_to_str, + primitive_float_bits, + primitive_double_bits, primitive_from_rect, primitive_fixnum_add, primitive_fixnum_subtract, diff --git a/native/s48_bignum.c b/native/s48_bignum.c index e7f8950e21..606a2e7d5c 100644 --- a/native/s48_bignum.c +++ b/native/s48_bignum.c @@ -412,6 +412,34 @@ s48_long_long_to_bignum(s64 n) } } +bignum_type +s48_ulong_long_to_bignum(u64 n) +{ + bignum_digit_type result_digits [BIGNUM_DIGITS_FOR_LONG_LONG]; + bignum_digit_type * end_digits = result_digits; + /* Special cases win when these small constants are cached. */ + if (n == 0) return (BIGNUM_ZERO ()); + if (n == 1) return (BIGNUM_ONE (0)); + { + u64 accumulator = n; + do + { + (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); + accumulator >>= BIGNUM_DIGIT_LENGTH; + } + while (accumulator != 0); + } + { + bignum_type result = + (bignum_allocate ((end_digits - result_digits), 0)); + bignum_digit_type * scan_digits = result_digits; + bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); + while (scan_digits < end_digits) + (*scan_result++) = (*scan_digits++); + return (result); + } +} + long s48_bignum_to_long(bignum_type bignum) { diff --git a/native/s48_bignum.h b/native/s48_bignum.h index 3fe8aa46fd..cc182ab2b3 100644 --- a/native/s48_bignum.h +++ b/native/s48_bignum.h @@ -67,7 +67,8 @@ bignum_type s48_bignum_quotient(bignum_type, bignum_type); bignum_type s48_bignum_remainder(bignum_type, bignum_type); DLLEXPORT bignum_type s48_long_to_bignum(long); DLLEXPORT bignum_type s48_long_long_to_bignum(s64 n); -bignum_type s48_ulong_to_bignum(unsigned long); +DLLEXPORT bignum_type s48_ulong_long_to_bignum(u64 n); +DLLEXPORT bignum_type s48_ulong_to_bignum(unsigned long); long s48_bignum_to_long(bignum_type); unsigned long s48_bignum_to_ulong(bignum_type); bignum_type s48_double_to_bignum(double);