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