<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html\r
<magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup\r
\r
+- fix ceiling\r
- single-stepper and variable access: wrong namespace?\r
- investigate if COPYING_GEN needs a fix\r
- faster layout\r
\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.
: 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 -- )
[ "(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 ] ] ]
[ "<complex>" "math-internals" [ [ real real ] [ number ] ] ]
[ "fixnum+" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ]
[ "fixnum-" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ]
#! 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.
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
>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 ;
+
+G: (B) ( dest aa lk -- ) [ pick ] [ type ] ;
+M: integer (B) i-form 18 insn ;
+M: word (B) 0 -rot (B) relative-24 ;
-GENERIC: B
-M: integer B 0 0 i-form 18 insn ;
-M: word B 0 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 ;
: 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 ;
--- /dev/null
+! 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 ;
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 ;
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
: 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
dup byte6 write
byte7 write ;
-: write-big-endian-64 ( word -- )
+: write-be64 ( word -- )
dup byte7 write
dup byte6 write
dup byte5 write
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 ;
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 ;
[ "\0\0\0\0\u000f\u000e\r\u000c" ]
[
- [ image-magic write-big-endian-64 ] with-string
+ [ image-magic write-be64 ] with-string
] 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
! 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
: 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 ;
: send-jedit-request ( request -- )
jedit-server-info swap "localhost" swap <client> [
- write-big-endian-32
- dup length write-big-endian-16
+ write-be32
+ dup length write-be16
write flush
] with-stream ;
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) \
{ \
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);
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,
}
}
+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)
{
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);
projects / factor.git / commitdiff