src/c/builtins.c~

   1 /* <Built-in procedures> */
   2
   3 /* Creates a closure and adds it to the top-level
   4    @param name (string) the name of the built-in procedure
   5    @param code (void*) the address of the built-in procedure (label address)
   6 */
   7 #define CREATE_BUILTIN_CLOS(name,code) \
   8     r_res = (int)getSymbol((name),topLevel); /* create a hash bucket */ \
   9     ((SymbolEntry*)r_res)->sob = makeSchemeClosure(NULL,(code)); \
  10     ASSERT_ALWAYS( ((SymbolEntry*)r_res)->sob!=NULL,"" ); \
  11     ((SymbolEntry*)r_res)->isDefined = 1;
  12
  13 /* The stack when in a built-in precedure (there is no fp):
  14   sp -> |      |
  15         | ret  |  - return address
  16           | sp   |  - the old sp (before entering this procedure)
  17         | env  |  - points to the enviroment vector
  18         | n    |  - number of arguments
  19         | A0   |  - argument 0
  20         | A1   |  - argument 1
  21         | ...  |  - ...
  22         | An-1 |  - argument n-1
  23
  24    Macros for built-in procedures:
  25 */
  26 #define BI_ST_ARG(n) (stack[sp-4-(n)])
  27 #define BI_ST_ARG_COUNT() (stack[sp-3])
  28 #define BI_RETURN() goto *pop()
  29
  30     goto Lstart; /* skip all definitions */
  31
  32 Lcar:
  33     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("car",1) );
  34     r[0] = BI_ST_ARG(0);
  35     ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
  36     r_res = (int)SOB_PAIR_CAR(r[0]);
  37     BI_RETURN();
  38
  39 Lcdr:
  40     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("cdr",1) );
  41     r[0] = BI_ST_ARG(0);
  42     ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
  43     r_res = (int)SOB_PAIR_CDR(r[0]);
  44     BI_RETURN();
  45
  46 Lsymbol:
  47     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("symbol?",1) );
  48     r[0] = BI_ST_ARG(0);
  49     if ( IS_SOB_SYMBOL(r[0]) ) goto Lsymbol_true;
  50     r_res = (int)&sc_false;
  51     BI_RETURN();
  52 Lsymbol_true:
  53     r_res = (int)&sc_true;
  54     BI_RETURN();
  55
  56 Lset_car:
  57     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("set-car!",2) );
  58     r[0] = BI_ST_ARG(0);
  59     r[1] = BI_ST_ARG(1);
  60     ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
  61     SOB_PAIR_CAR(r[0]) = (SchemeObject*)r[1];
  62     r_res = r[1];
  63     BI_RETURN();
  64
  65 Lmake_vector:
  66     ASSERT_ALWAYS( BI_ST_ARG_COUNT()>=1,MSG_ERR_ARGCOUNT("make-vector",1) );
  67     r[0] = BI_ST_ARG(0);
  68     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
  69     r[0] = SOB_INT_VALUE(r[0]);
  70     r_res = (int)makeSchemeVectorInit(r[0],&sc_void);
  71     /* initialize vector elements
  72     for (int i=1; i<BI_ST_ARG_COUNT(); ++i)
  73         SOB_VECTOR_SET(r_res,i,BI_ST_ARG(i));
  74     */
  75     BI_RETURN();
  76
  77 Lvector_set:
  78     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==3,MSG_ERR_ARGCOUNT("vector-set!",3) );
  79     r[0] = BI_ST_ARG(0);
  80     ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), "");
  81     r[1] = BI_ST_ARG(1);
  82     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
  83     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
  84     r[2] = BI_ST_ARG(2);
  85     SOB_VECTOR_SET((SchemeObject*)r[0],r[1],(SchemeObject*)r[2]);
  86     r_res = (int)&sc_void;
  87     BI_RETURN();
  88
  89 Lvector_ref:
  90     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("vector-ref",2) );
  91     r[0] = BI_ST_ARG(0);
  92     ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), "");
  93     r[1] = BI_ST_ARG(1);
  94     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
  95     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
  96     r_res = (int)SOB_VECTOR_REF((SchemeObject*)r[0],r[1]);
  97     BI_RETURN();
  98
  99 LbinaryEQ:
 100     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary=?",2) );
 101     r[0] = BI_ST_ARG(0);
 102     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 103     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 104     r[1] = BI_ST_ARG(1);
 105     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 106     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 107     if (r[0] != r[1]) goto LbinaryEQ_false;
 108     r_res = (int)&sc_true;
 109     BI_RETURN();
 110 LbinaryEQ_false:
 111     r_res = (int)&sc_false;
 112     BI_RETURN();
 113
 114 LbinaryADD:
 115     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-add",2) );
 116     r[0] = BI_ST_ARG(0);
 117     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 118     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 119     r[1] = BI_ST_ARG(1);
 120     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 121     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 122     r_res = r[0] + r[1];
 123     r_res = (int)makeSchemeInt( r_res );
 124     BI_RETURN();
 125
 126 LbinarySUB:
 127     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-sub",2) );
 128     r[0] = BI_ST_ARG(0);
 129     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 130     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 131     r[1] = BI_ST_ARG(1);
 132     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 133     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 134     r_res = r[0] - r[1];
 135     r_res = (int)makeSchemeInt( r_res );
 136     BI_RETURN();
 137
 138 LbinaryMUL:
 139     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-mul",2) );
 140     r[0] = BI_ST_ARG(0);
 141     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 142     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 143     r[1] = BI_ST_ARG(1);
 144     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 145     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 146     r_res = (int)r[0] * (int)r[1]; /* multiply as signed integers */
 147     r_res = (int)makeSchemeInt( r_res );
 148     BI_RETURN();
 149
 150 LbinaryDIV:
 151     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-div",2) );
 152     r[0] = BI_ST_ARG(0);
 153     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 154     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 155     r[1] = BI_ST_ARG(1);
 156     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 157     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 158     r_res = (int)r[0] / (int)r[1]; /* divide as signed integers */
 159     r_res = (int)makeSchemeInt( r_res );
 160     BI_RETURN();
 161
 162 LbinaryLT:
 163     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary<?",2) );
 164     r[0] = BI_ST_ARG(0);
 165     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
 166     r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
 167     r[1] = BI_ST_ARG(1);
 168     ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
 169     r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
 170     r_res = ((int)r[0] < (int)r[1]); /* compare as signed integers */
 171     r_res = (int)makeSchemeBool( r_res );
 172     BI_RETURN();
 173
 174 Lbox:
 175     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("box",1) );
 176     r[0] = BI_ST_ARG(0);
 177     r_res = (int)makeSchemeVectorInit( 1,(SchemeObject*)(r[0]) );
 178     BI_RETURN();
 179
 180 Lnull:
 181     ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("null?",1) );
 182     r[0] = BI_ST_ARG(0);
 183     r_res = (int)makeSchemeBool( IS_SOB_NIL(r[0]) );
 184     BI_RETURN();
 185
 186 Lstart:
 187     /* create closures for the free variables of the built-in procedures */
 188     CREATE_BUILTIN_CLOS("car"           ,&&Lcar);
 189     CREATE_BUILTIN_CLOS("cdr"           ,&&Lcdr);
 190     CREATE_BUILTIN_CLOS("symbol?"       ,&&Lsymbol);
 191     CREATE_BUILTIN_CLOS("set-car!"      ,&&Lset_car);
 192     CREATE_BUILTIN_CLOS("make-vector"   ,&&Lmake_vector);
 193     CREATE_BUILTIN_CLOS("vector-set!"   ,&&Lvector_set);
 194     CREATE_BUILTIN_CLOS("vector-ref"    ,&&Lvector_ref);
 195     CREATE_BUILTIN_CLOS("binary=?"      ,&&LbinaryEQ);
 196     CREATE_BUILTIN_CLOS("binary-add"    ,&&LbinaryADD);
 197     CREATE_BUILTIN_CLOS("binary-sub"    ,&&LbinarySUB);
 198     CREATE_BUILTIN_CLOS("binary-mul"    ,&&LbinaryMUL);
 199     CREATE_BUILTIN_CLOS("binary-mul"    ,&&LbinaryMUL);
 200     CREATE_BUILTIN_CLOS("binary-div"    ,&&LbinaryDIV);
 201     CREATE_BUILTIN_CLOS("binary<?"      ,&&LbinaryLT);
 202     CREATE_BUILTIN_CLOS("box"           ,&&Lbox);
 203     CREATE_BUILTIN_CLOS("null?"         ,&&Lnull);
 204 /*
 205     CREATE_BUILTIN_CLOS("",&&L);
 206     */
 207
 208 /* </Built-in procedures> */