[Gcl-devel] GCL and complex arithmetic

[Camm Maguire]

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                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah