GCL and complex arithmetic
- Subject: GCL and complex arithmetic
- From: Camm Maguire
- Date: Fri, 15 Jun 2007 20:25:39 -0400
Greetings! GCL now supports unboxed complex arithmetic using the C99
C semantics for complex operations. THis is precisely akin to the
traditional support for unboxed fixnums, short and double floats. My
commenst below next to ***:
=============================================================================
>(disassemble 'sin nil)
;; Compiling /tmp/gazonk_22733_0.lsp.
;; End of Pass 1.
;; End of Pass 2.
;; OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3, (Debug quality ignored)
;; Finished compiling /tmp/gazonk_22733_0.o.
#include "gazonk_22733_0.h"
void init_code(){do_init((void *)VV);}
/* local entry for function SIN */
static object LI1(V2)
register object V2;
{ VMB1 VMS1 VMV1
goto TTL;
TTL:;
if(!(numberp((V2)))){
goto T5;}
goto T3;
goto T5;
T5:;
V2= (VFUN_NARGS=4,(/* CHECK-TYPE-SYMBOL */(*LnkLI7)(((object)VV[0]),(V2),((object)VV[1]),Cnil)));
goto T3;
T3:;
{register object V4;
V4= V2;
/*(CNUM-TYPE X)*/
{object V6;
V6= (V4);
{fixnum V7;
V7= (fixnum)type_of((V6));
V8 = V7;
if(!((V8)!=((fixnum)6))){
goto T10;}
V5= V7;
goto T7;
goto T10;
T10:;switch((fixnum)type_of(((V6))->cmp.cmp_real)){
case 4:
goto T13;
T13:;
V5= (fixnum)30;
goto T7;
case 5:
goto T14;
T14:;
V5= (fixnum)31;
goto T7;
default:
goto T15;
T15:;
V5= (fixnum)6;
goto T7;
V5= fix(Cnil);
goto T7;}
V5= fix(Cnil);}}
/* END (CNUM-TYPE X)*/
goto T7;
T7:;switch(V5){
case 5:
goto T18;
T18:;
{object V9 = make_longfloat(((double(*)(double))dlsin)(lf((V4))));VMR1
(V9);}
case 4:
goto T19;
T19:;
{object V10 = make_shortfloat(((float(*)(float))dlsinf)(sf((V4))));VMR1
(V10);}
case 1:
goto T20;
T20:;
case 2:
goto T21;
T21:;
case 3:
goto T22;
T22:;
/*(FLOAT X 0.0)*/
{register object V12;
register double V13;
V12= (V4);
V13= lf(((object)VV[2]));
V13= lf(((object)VV[2]));
{register object V14;
V14= (V12);
/*(CNUM-TYPE X)*/
{register object V16;
V16= (V14);
{register fixnum V17;
V17= (fixnum)type_of((V16));
V15= V17;}}
/* END (CNUM-TYPE X)*/switch(V15){
case 1:
goto T43;
T43:;
V11= ( 1. )*(fix((V14)));
goto T32;
case 2:
goto T44;
T44:;
{register double V18;
V18= big_to_double((V14));
V11= V18;
goto T32;}
case 3:
goto T45;
T45:;
{register double V19;
base[0]= (V14);
vs_top=(vs_base=base+0)+1;
(void) (*Lnk8)();
vs_top=sup;
V19= lf(({register object _z=vs_base[0];_z;}));
V11= V19;
goto T32;}
V11= lf(Cnil);
goto T32;}
V11= lf(Cnil);}}
/* END (FLOAT X 0.0)*/
goto T32;
T32:;
{object V20 = make_longfloat(((double(*)(double))dlsin)(V11));VMR1
(V20);}
case 31:
goto T23;
T23:; *** lfc/sfc are C macros unboxing a complex from the lisp object
{object V21 = make_dcomplex(((dcomplex(*)(dcomplex))dlcsin)(lfc((V4))));VMR1
(V21);}
case 30:
goto T24;
T24:;
{object V22 = make_fcomplex(((fcomplex(*)(fcomplex))dlcsinf)(sfc((V4))));VMR1
(V22);}
default:
goto T25;
T25:;
/*(FLOAT (REALPART X) 0.0)*/
{register object V24;
register double V25;
{object V26;
/*(REALPART X)*/
{register object V27;
V27= (V4);
{register object V28;
V28= (V27);
/*(CNUM-TYPE X)*/
{register object V29;
V29= (V28);switch((fixnum)type_of(((V29))->cmp.cmp_real)){
default:
goto T70;
T70:;
goto T68;
goto T68;}}
/* END (CNUM-TYPE X)*/
goto T68;
T68:;
V26= ((V28))->cmp.cmp_real;}}
/* END (REALPART X)*/
V24=V26;}
V25= lf(((object)VV[2]));
V25= lf(((object)VV[2]));
{register object V30;
V30= (V24);
/*(CNUM-TYPE X)*/
{register object V16;
V16= (V30);
{register fixnum V17;
V17= (fixnum)type_of((V16));
V31= V17;}}
/* END (CNUM-TYPE X)*/switch(V31){
case 1:
goto T84;
T84:;
V23= ( 1. )*(fix((V30)));
goto T63;
case 2:
goto T85;
T85:;
{register double V32;
V32= big_to_double((V30));
V23= V32;
goto T63;}
case 3:
goto T86;
T86:;
{register double V33;
base[0]= (V30);
vs_top=(vs_base=base+0)+1;
(void) (*Lnk8)();
vs_top=sup;
V33= lf(({register object _z=vs_base[0];_z;}));
V23= V33;
goto T63;}
V23= lf(Cnil);
goto T63;}
V23= lf(Cnil);}}
/* END (FLOAT (REALPART X) 0.0)*/
goto T63;
T63:;
/*(FLOAT (IMAGPART X) 0.0)*/
{register object V35;
register double V36;
{object V37;
/*(IMAGPART X)*/
{register object V38;
V38= (V4);
{register object V39;
V39= (V38);
/*(CNUM-TYPE X)*/
{register object V29;
V29= (V39);switch((fixnum)type_of(((V29))->cmp.cmp_real)){
default:
goto T104;
T104:;
goto T102;
goto T102;}}
/* END (CNUM-TYPE X)*/
goto T102;
T102:;
V37= ((V39))->cmp.cmp_imag;}}
/* END (IMAGPART X)*/
V35=V37;}
V36= lf(((object)VV[2]));
V36= lf(((object)VV[2]));
{register object V40;
V40= (V35);
/*(CNUM-TYPE X)*/
{register object V16;
V16= (V40);
{register fixnum V17;
V17= (fixnum)type_of((V16));
V41= V17;}}
/* END (CNUM-TYPE X)*/switch(V41){
case 1:
goto T118;
T118:;
V34= ( 1. )*(fix((V40)));
goto T97;
case 2:
goto T119;
T119:;
{register double V42;
V42= big_to_double((V40));
V34= V42;
goto T97;}
case 3:
goto T120;
T120:;
{register double V43;
base[0]= (V40);
vs_top=(vs_base=base+0)+1;
(void) (*Lnk8)();
vs_top=sup;
V43= lf(({register object _z=vs_base[0];_z;}));
V34= V43;
goto T97;}
V34= lf(Cnil);
goto T97;}
V34= lf(Cnil);}}
/* END (FLOAT (IMAGPART X) 0.0)*/
goto T97;
T97:; *** V23 + I * V34 is the C expression generating the complex
*** from two reals
{object V44 = make_dcomplex(((dcomplex(*)(dcomplex))dlcsin)((V23 + I * V34)));VMR1
(V44);}
{object V45 = Cnil;VMR1
(V45);}}
{object V46 = Cnil;VMR1
(V46);}}
base[0]=base[0];
return Cnil;
}
static void LnkT8(){ call_or_link(((object)VV[8]),0,(void **)(void *)&Lnk8);} /* RATIO-TO-DOUBLE */
static object LnkTLI7(object first,...){object V1;va_list ap;va_start(ap,first);V1=(object )call_vproc_new(((object)VV[7]),0,0,(void **)(void *)&LnkLI7,first,ap);va_end(ap);return V1;} /* CHECK-TYPE-SYMBOL */
#(#(X NUMBER NIL (OR NULL FLOAT) REAL SHORT-FLOAT 1.0 CHECK-TYPE-SYMBOL
RATIO-TO-DOUBLE
(%INIT
. #((MDL 'sin 'libm 1) (MDL 'sinf 'libm 2) (MDL 'csin 'libm 3)
(MDL 'csinf 'libm 4)
(LET ((*DISABLE-RECOMPILE* T))
(SETVV 2 (* 0.0 LEAST-POSITIVE-LONG-FLOAT))
(MFSFUN 'SIN 0 1 0)
(ADD-HASH 'SIN
'((NUMBER)
(OR (LONG-FLOAT -1.0 1.0) (SHORT-FLOAT -1.0S0 1.0S0)
FCOMPLEX DCOMPLEX))
'((IMAGPART (NUMBER) REAL) (REALPART (NUMBER) REAL)
(COMPLEX (*) *) (csinf (NUMBER) T) (csin (NUMBER) T)
(FLOAT (REAL *) FLOAT) (sinf (FLOAT) T)
(sin (FLOAT) T) (CNUM-TYPE (T) (INTEGER 0 31))
(CHECK-TYPE-SYMBOL (T T T *) T) (NUMBERP (T) BOOLEAN)
(TYPEP (T T *) T))
SYSTEM,DECLAR,OPTIMIZ,SAFETY
,CHECK-TYPE-,NUMBER ,BLOCK,SIN ,LET--,CAS .CNUM-TYPE- ?,SETQ- !,THE!
libmsin- ?? ?? ,SHORT-FLOAT3sinf- ?? ???????????? ?,FLOAT-
0.0) ?? ????????????3csin-
?? ???????????3csinf- ,OTHERWISE /- ,NOT,OR975418 ,COMPLEX ,REALPART-
0.0) ,IMAGPART-
0.0)
'/tmp/gazonk_22733_0.lsp))
(DO-RECOMPILE)))))
static object LI1();
static void *dlsin;
static void *dlsinf;
static void *dlcsin;
static void *dlcsinf;
#define VMB1 register object *base=vs_top; fixnum V41; double V34; fixnum V31; double V23; fixnum V15; double V11; fixnum V8; fixnum V5;
#define VMS1 register object *sup=vs_top+1;vs_top=sup;
#define VMV1 vs_check;
#define VMR1(VMT1) vs_top=base ; return(VMT1);
#define VM1 1
static void * VVi[10]={
#define Cdata VV[9]
(void *)(LI1),
(void *)(&dlsin),
(void *)(&dlsinf),
(void *)(&dlcsin),
(void *)(&dlcsinf)
};
#define VV (VVi)
static void LnkT8();
static void (*Lnk8)() = LnkT8;
static object LnkTLI7(object,...);
static object (*LnkLI7)() = (object (*)()) LnkTLI7;
NIL
>(disassemble '(lambda (x y z) (declare (long-float z)((complex long-float) x y)) (* z (+ z (* x (+ x y))))) nil)
;; Compiling /tmp/gazonk_22733_1.lsp.
;; End of Pass 1.
;; End of Pass 2.
;; OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3, (Debug quality ignored)
;; Finished compiling /tmp/gazonk_22733_1.o.
#include "gazonk_22733_1.h"
void init_code(){do_init((void *)VV);}
/* local entry for function CMP-ANON */
static dcomplex LI1(V4,V5,V6)
dcomplex V4;dcomplex V5;double V6;
{ VMB1 VMS1 VMV1
goto TTL;
TTL:; *** unboxed C multiplication etc.
{dcomplex V7 = (V6)*((V6)+((V4)*((V4)+(V5))));VMR1
(V7);}
}
/* global entry for the function CMP-ANON */
static void L1()
{ register object *base=vs_base;
base[0]=make_dcomplex(LI1(lfc(base[0]),lfc(base[1]),lf(base[2])));
vs_top=(vs_base=base)+1;
}
#(#((%INIT
. #((LET ((*DISABLE-RECOMPILE* T))
(MF 'CMP-ANON 0)
(ADD-HASH 'CMP-ANON
'((DCOMPLEX DCOMPLEX LONG-FLOAT) DCOMPLEX)
'((+ (*) T) (* (*) T))
LISPLAMBDA !X!Y!!,DECLAR,OPTIMIZ,SAFETY� ?COMPILERCMP-ANON !,*/ !,+/ 3- 4-.
'/tmp/gazonk_22733_1.lsp))
(DO-RECOMPILE)))))
static void L1();
static dcomplex LI1();
#define VMB1
#define VMS1
#define VMV1
#define VMR1(VMT1) return(VMT1);
#define VM1 0
static void * VVi[1]={
#define Cdata VV[0]
(void *)(L1)
};
#define VV (VVi)
NIL
>
=============================================================================
Enjoy!
Take care,
--
Camm Maguire camm at enhanced.com
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah