1 /* <Built-in procedures> */
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)
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;
13 /* The stack when in a built-in precedure (there is no fp):
15 | ret | - return address
16 | env | - points to the enviroment vector
17 | n | - number of arguments
21 | An-1 | - argument n-1
23 Macros for built-in procedures:
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()
29 goto Lstart
; /* skip all definitions */
32 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT(1) );
34 ASSERT_ALWAYS( IS_SOB_PAIR(r
[0]), MSG_ERR_NOTPAIR
);
35 r_res
= (int)SOB_PAIR_CAR(r
[0]);
39 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT(1) );
41 ASSERT_ALWAYS( IS_SOB_PAIR(r
[0]), MSG_ERR_NOTPAIR
);
42 r_res
= (int)SOB_PAIR_CDR(r
[0]);
46 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT(1) );
48 if ( IS_SOB_SYMBOL(r
[0]) ) goto Lsymbol_true
;
49 r_res
= (int)&sc_false
;
52 r_res
= (int)&sc_true
;
56 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT(2) );
59 ASSERT_ALWAYS( IS_SOB_PAIR(r
[0]), MSG_ERR_NOTPAIR
);
60 SOB_PAIR_CAR(r
[0]) = (SchemeObject
*)r
[1];
65 ASSERT_ALWAYS( BI_ST_ARG_COUNT()>=1,MSG_ERR_ARGCOUNT(1) );
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));
77 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==3,MSG_ERR_ARGCOUNT(3) );
79 ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject
*)r
[0]), "");
81 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject
*)r
[1]), "");
82 r
[1] = SOB_INT_VALUE((SchemeObject
*)r
[1]);
84 SOB_VECTOR_SET((SchemeObject
*)r
[0],r
[1],(SchemeObject
*)r
[2]);
85 r_res
= (int)&sc_void
;
89 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT(2) );
91 ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject
*)r
[0]), "");
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]);
99 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT(2) );
101 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject
*)r
[0]), "");
102 r
[0] = SOB_INT_VALUE((SchemeObject
*)r
[0]);
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
;
110 r_res
= (int)&sc_false
;
114 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT(2) );
116 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject
*)r
[0]), "");
117 r
[0] = SOB_INT_VALUE((SchemeObject
*)r
[0]);
119 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject
*)r
[1]), "");
120 r
[1] = SOB_INT_VALUE((SchemeObject
*)r
[1]);
122 r_res
= (int)makeSchemeInt( r_res
);
126 /* create closures for the free variables of the built-in procedures */
127 CREATE_BUILTIN_CLOS("car",&&Lcar
);
128 CREATE_BUILTIN_CLOS("cdr",&&Lcdr
);
129 CREATE_BUILTIN_CLOS("symbol?",&&Lsymbol
);
130 CREATE_BUILTIN_CLOS("set-car!",&&Lset_car
);
131 CREATE_BUILTIN_CLOS("make-vector",&&Lmake_vector
);
132 CREATE_BUILTIN_CLOS("vector-set!",&&Lvector_set
);
133 CREATE_BUILTIN_CLOS("vector-ref",&&Lvector_ref
);
134 CREATE_BUILTIN_CLOS("binary=?",&&LbinaryEQ
);
135 CREATE_BUILTIN_CLOS("binary-add",&&LbinaryADD
);
137 /* </Built-in procedures> */