| 31 | | /// ���ɕϐ���^ |
| 32 | | /** |
| 33 | | @return �C���f�N�X |
| 34 | | */ |
| 35 | | static SExp compile_define_var(SExp env, SExp var) { |
| 36 | | SExp e = car(env); |
| 37 | | int l; |
| 38 | | if (nilp(e)) { |
| 39 | | rplaca(env, cons(var, nil)); |
| 40 | | l = 0; |
| 41 | | } else { |
| 42 | | l = length(e); |
| 43 | | rplacd(last_pair(e), cons(var, nil)); |
| 44 | | } |
| 45 | | return int2s(l); |
| 46 | | } |
| 47 | | |
| 48 | | /// ���[�J�����ɕϐ���^ |
| 49 | | static SExp compile_define_local(SExp env, SExp var) { |
| 50 | | return cons(int2s(0), compile_define_var(env, var)); |
| 51 | | } |
| 52 | | |
| 53 | | /// ���[�J�����ɕϐ���^ |
| 54 | | static SExp compile_define_global(SExp env, SExp var) { |
| 55 | | return cons(int2s(length(env) - 1), compile_define_var(last_pair(env), var)); |
| 56 | | } |
| 57 | | |
| 58 | | |
| 59 | | /// �ϐ��Q�� |
| 60 | | static SExp compile_lookup(SExp var, SExp e) { |
| 61 | | int rib = 0; |
| 62 | | for (;; e = cdr(e), ++rib) { |
| 63 | | if (nilp(e)) return nil; |
| 64 | | SExp vars = car(e); |
| 65 | | int elt = 0; |
| 66 | | for (;; vars = cdr(vars), ++elt) { |
| 67 | | if (nilp(vars)) break; |
| 68 | | if (eq(car(vars), var)) return cons(int2s(rib), int2s(elt)); |
| 69 | | } |
| 70 | | } |
| 71 | | } |
| | 69 | |
| | 70 | |
| | 71 | static SExp find_sets(SExp x, SExp v) { |
| | 72 | if (symbolp(x)) { |
| | 73 | return nil; |
| | 74 | } else if (consp(x)) { |
| | 75 | SExp op = car(x); |
| | 76 | if (eq(op, intern("quote"))) { |
| | 77 | return nil; |
| | 78 | } else if (eq(op, intern("lambda"))) { |
| | 79 | SExp vars = cadr(x); |
| | 80 | SExp body = caddr(x); |
| | 81 | return find_sets(body, set_minus(v, vars)); |
| | 82 | } else if (eq(op, intern("if"))) { |
| | 83 | SExp test = cadr(x); |
| | 84 | SExp then = caddr(x); |
| | 85 | |
| | 86 | SExp r = set_union(find_sets(test, v), find_sets(then, v)); |
| | 87 | SExp ddd = cdddr(x); |
| | 88 | if (!nilp(ddd)) { |
| | 89 | SExp els = car(ddd); |
| | 90 | r = set_union(r, find_sets(els, v)); |
| | 91 | } |
| | 92 | return r; |
| | 93 | } else if (eq(op, intern("set!"))) { |
| | 94 | SExp var = cadr(x); |
| | 95 | SExp exp = caddr(x); |
| | 96 | if (set_memberp(var, v)) |
| | 97 | return set_union(list(1, var), find_sets(exp, v)); |
| | 98 | else |
| | 99 | return find_sets(exp, v); |
| | 100 | } else if (eq(op, intern("call/cc"))) { |
| | 101 | SExp exp = cadr(x); |
| | 102 | return find_sets(exp, v); |
| | 103 | } else { |
| | 104 | SExp r = nil; |
| | 105 | for (;; x = cdr(x)) { |
| | 106 | if (nilp(x)) break; |
| | 107 | r = set_union(find_sets(car(x), v), r); |
| | 108 | } |
| | 109 | return r; |
| | 110 | } |
| | 111 | } else { |
| | 112 | return nil; |
| | 113 | } |
| | 114 | } |
| | 115 | |
| | 116 | static SExp make_boxes_loop(SExp sets, SExp vars, SExp next, int n) { |
| | 117 | if (nilp(vars)) |
| | 118 | return next; |
| | 119 | else if (set_memberp(car(vars), sets)) |
| | 120 | return list(3, BOX, int2s(n), make_boxes_loop(sets, cdr(vars), next, n + 1)); |
| | 121 | else |
| | 122 | return make_boxes_loop(sets, cdr(vars), next, n + 1); |
| | 123 | } |
| | 124 | |
| | 125 | static SExp make_boxes(SExp sets, SExp vars, SExp next) { |
| | 126 | return make_boxes_loop(sets, vars, next, 0); |
| | 127 | } |
| | 128 | |
| | 129 | |
| | 130 | //============================================================================= |
| | 131 | |
| | 132 | static VarType compile_lookup(int* pidx, SExp x, SExp e) { |
| | 133 | SExp locals = car(e); |
| | 134 | int n = 0; |
| | 135 | nxtlocal:; |
| | 136 | if (!nilp(locals)) { |
| | 137 | if (!eq(car(locals), x)) { |
| | 138 | locals = cdr(locals); ++n; |
| | 139 | goto nxtlocal; |
| | 140 | } else { |
| | 141 | *pidx = n; |
| | 142 | return VarLocal; |
| | 143 | } |
| | 144 | } else { |
| | 145 | SExp free = cdr(e); |
| | 146 | int n = 0; |
| | 147 | nxtfree:; |
| | 148 | if (!nilp(free)) { |
| | 149 | if (eq(car(free), x)) { |
| | 150 | *pidx = n; |
| | 151 | return VarFree; |
| | 152 | } else { |
| | 153 | free = cdr(free); ++n; |
| | 154 | goto nxtfree; |
| | 155 | } |
| | 156 | } else { |
| | 157 | return VarUndef; |
| | 158 | } |
| | 159 | } |
| | 160 | } |
| | 161 | |
| | 162 | static SExp compile_refer(SExp x, SExp e, SExp next) { |
| | 163 | int n; |
| | 164 | switch (compile_lookup(&n, x, e)) { |
| | 165 | default: assert(false); return nil; |
| | 166 | case VarLocal: return list(3, REFER_LOCAL, int2s(n), next); |
| | 167 | case VarFree: return list(3, REFER_FREE, int2s(n), next); |
| | 168 | case VarUndef: return list(3, REFER_GLOBAL, x, next); |
| | 169 | } |
| | 170 | } |
| | 171 | |
| | 172 | static SExp collect_free(SExp vars, SExp e, SExp next) { |
| | 173 | if (nilp(vars)) |
| | 174 | return next; |
| | 175 | else |
| | 176 | return collect_free(cdr(vars), e, compile_refer(car(vars), e, list(2, ARGUMENT, next))); |
| | 177 | } |
| | 178 | |
| | 179 | static SExp find_free(SExp x, SExp b) { |
| | 180 | if (symbolp(x)) { |
| | 181 | if (set_memberp(x, b)) { |
| | 182 | return nil; |
| | 183 | } else { |
| | 184 | return cons(x, nil); |
| | 185 | } |
| | 186 | } else if (consp(x)) { |
| | 187 | SExp op = car(x); |
| | 188 | if (eq(op, intern("quote"))) { |
| | 189 | return nil; |
| | 190 | } else if (eq(op, intern("lambda"))) { |
| | 191 | SExp vars = cadr(x); |
| | 192 | SExp body = caddr(x); |
| | 193 | return find_free(body, set_union(vars, b)); |
| | 194 | } else if (eq(op, intern("if"))) { |
| | 195 | SExp test = cadr(x); |
| | 196 | SExp then = caddr(x); |
| | 197 | |
| | 198 | SExp r = set_union(find_free(test, b), find_free(then, b)); |
| | 199 | SExp ddd = cdddr(x); |
| | 200 | if (!nilp(ddd)) { |
| | 201 | SExp els = car(ddd); |
| | 202 | r = set_union(r, find_free(els, b)); |
| | 203 | } |
| | 204 | return r; |
| | 205 | } else if (eq(op, intern("set!"))) { |
| | 206 | SExp var = cadr(x); |
| | 207 | SExp exp = caddr(x); |
| | 208 | if (set_memberp(var, b)) |
| | 209 | return find_free(exp, b); |
| | 210 | else |
| | 211 | return set_union(list(1, var), find_free(exp, b)); |
| | 212 | } else if (eq(op, intern("call/cc"))) { |
| | 213 | SExp exp = cadr(x); |
| | 214 | return find_free(exp, b); |
| | 215 | } else { |
| | 216 | SExp r = nil; |
| | 217 | for (;; x = cdr(x)) { |
| | 218 | if (nilp(x)) break; |
| | 219 | r = set_union(find_free(car(x), b), r); |
| | 220 | } |
| | 221 | return r; |
| | 222 | } |
| | 223 | } else { |
| | 224 | return nil; |
| | 225 | } |
| | 226 | } |
| | 227 | |
| | 228 | |
| | 229 | static SExp filter_member(SExp mem, SExp ls) { |
| | 230 | SExp acc = nil; |
| | 231 | for (; !nilp(ls); ls = cdr(ls)) { |
| | 232 | SExp x = car(ls); |
| | 233 | if (memq(x, mem)) { |
| | 234 | acc = cons(x, acc); |
| | 235 | } |
| | 236 | } |
| | 237 | return nreverse(acc); |
| | 238 | } |
| | 239 | |
| | 240 | |
| | 241 | |
| 82 | | return compile_pair_loop(cdr(args), compile(car(args), e, list(2, ARGUMENT, c)), e, next); |
| 83 | | } |
| 84 | | } |
| 85 | | |
| 86 | | /// set! ����p�C�� |
| 87 | | static SExp compile_set(SExp op, SExp sym, SExp val, SExp e, SExp next, bool b_define) { |
| 88 | | SExp access = compile_lookup(sym, e); |
| 89 | | if (nilp(access)) { |
| 90 | | if (b_define) { |
| 91 | | access = compile_define_local(e, sym); |
| 92 | | } else { |
| 93 | | compile_error(ERR_UNDEFINED_SYMBOL); |
| 94 | | } |
| 95 | | } |
| 96 | | return compile(val, e, list(3, op, access, next)); |
| 97 | | } |
| 98 | | |
| 99 | | /// define ����p�C�� |
| 100 | | static SExp compile_define(SExp var, SExp xs, SExp e, SExp next) { |
| 101 | | while (consp(var)) { |
| 102 | | SExp fname = car(var); |
| 103 | | SExp args = cdr(var); |
| 104 | | |
| 105 | | var = fname; |
| 106 | | xs = cons(cons(intern("lambda"), cons(args, xs)), nil); |
| 107 | | } |
| 108 | | return compile_set(DEFINE, var, car(xs), e, next, true); |
| 109 | | } |
| 110 | | |
| 111 | | /// �u���b�N�R���p�C�����́A���̖��� |
| 112 | | static SExp get_next(SExp sexps, SExp next) { |
| 113 | | if (singlep(sexps)) |
| 114 | | return cons(car(next), cdr(next)); |
| 115 | | else |
| 116 | | return cons(HALT, nil); |
| 117 | | } |
| 118 | | |
| 119 | | /// �����̎�����p�C�� |
| | 252 | return compile_pair_loop(cdr(args), compile(car(args), e, s, list(2, ARGUMENT, c)), e, s, next); |
| | 253 | } |
| | 254 | } |
| | 255 | |
| | 256 | |
| | 257 | //============================================================================= |
| | 258 | |
| | 259 | /// ����void init_compile(void) { |
| | 260 | } |
| | 261 | |
| 121 | | SExp start = get_next(sexps, next); |
| 122 | | for (SExp prev = start; !nilp(sexps); sexps = cdr(sexps)) { |
| 123 | | SExp se = car(sexps); |
| 124 | | SExp nx = get_next(sexps, next); |
| 125 | | SExp r = compile(se, e, nx); |
| 126 | | rplaca(prev, car(r)); |
| 127 | | rplacd(prev, cdr(r)); |
| 128 | | |
| 129 | | prev = nx; |
| 130 | | } |
| 131 | | return start; |
| 132 | | } |
| 133 | | |
| 134 | | |
| 135 | | |
| 136 | | /// �}�N���� |
| 137 | | static void compile_defmacro(SExp name, SExp vars, SExp body) { |
| 138 | | SExp mac = cons(name, cons(intern("lambda"), cons(vars, body))); |
| 139 | | s_macros = cons(mac, s_macros); |
| 140 | | } |
| 141 | | |
| 142 | | SExp is_macro(SExp name) { |
| 143 | | return assoc(name, s_macros); |
| 144 | | } |
| 145 | | |
| 146 | | /// �}�N���Ăяo���R�[�h�쐬 |
| 147 | | static SExp quotize(SExp s) { |
| 148 | | return list(2, intern("quote"), s); |
| 149 | | } |
| 150 | | static SExp gen_macro_call(SExp m, SExp x) { |
| 151 | | return cons(cdr(m), mapcar(quotize, cdr(x))); |
| 152 | | } |
| 153 | | |
| 154 | | /// �}�N����i�W�J |
| 155 | | SExp macroexpand_1(SExp m, SExp x) { |
| 156 | | SExp code = gen_macro_call(m, x); |
| 157 | | return evaluate(code); |
| 158 | | } |
| 159 | | |
| 160 | | /// �}�N���K�p |
| 161 | | static SExp compile_macro_apply(SExp m, SExp x, SExp e, SExp next) { |
| 162 | | SExp trans = macroexpand_1(m, x); |
| 163 | | return compile(trans, e, next); |
| 164 | | } |
| 165 | | |
| 166 | | |
| 167 | | |
| 168 | | /// �o�b�N�N�H�[�g�̕ϊ� |
| 169 | | |
| 170 | | static SExp transform_quasiquote_loop(SExp x) { |
| 171 | | if (!consp(x)) return list(2, intern("quote"), list(1, x)); |
| 172 | | else if (eq(car(x), intern("unquote"))) return list(2, intern("list"), cadr(x)); |
| 173 | | else if (eq(car(x), intern("unquote-splicing"))) return cadr(x); |
| 174 | | else return list(2, intern("list"), cons(intern("append"), mapcar(transform_quasiquote_loop, x))); |
| 175 | | } |
| 176 | | |
| 177 | | static SExp transform_quasiquote(SExp x) { |
| 178 | | SExp res = transform_quasiquote_loop(x); |
| 179 | | SExp hd = car(res); |
| 180 | | if (eq(hd, intern("list"))) return cadr(res); |
| 181 | | else if (eq(hd, intern("quote"))) return list(2, intern("quote"), car(cadr(res))); |
| 182 | | else { assert(!"unexpected"); return nil; } |
| 183 | | } |
| 184 | | |
| 185 | | /// �h�b�g�y�A�̈ʒu��� |
| 186 | | static int dotted_pos(SExp ls) { |
| 187 | | for (int pos = 0; ; ++pos, ls = cdr(ls)) { |
| 188 | | if (nilp(ls)) return -1; |
| 189 | | if (!consp(ls)) return pos; |
| 190 | | } |
| 191 | | } |
| 192 | | |
| 193 | | /// REST �p�����[�^����H |
| 194 | | static bool has_rest_param(SExp* prest, SExp* pmodvars, SExp vars) { |
| 195 | | int pos = dotted_pos(vars); |
| 196 | | if (pos >= 0) { |
| 197 | | if (pos == 0) { |
| 198 | | *pmodvars = cons(vars, nil); |
| 199 | | } else { |
| 200 | | SExp copied = list_copy(vars); |
| 201 | | SExp last = last_pair(copied); |
| 202 | | rplacd(last, cons(cdr(last), nil)); |
| 203 | | *pmodvars = copied; |
| 204 | | } |
| 205 | | *prest = int2s(pos); |
| 206 | | return true; |
| 207 | | } else { |
| 208 | | return false; |
| 209 | | } |
| 210 | | } |
| 211 | | |
| 212 | | /// lambda ���̃R���p�C�� |
| 213 | | static SExp compile_lambda(SExp rest, SExp vars, SExp body, SExp e, SExp next) { |
| 214 | | return list(3, CLOSE, cons(rest, compile_block(body, extend(e, vars), list(1, RETURN))), next); |
| 215 | | } |
| 216 | | |
| 217 | | /// ����void init_compile(void) { |
| 218 | | s_macros = nil; |
| | 263 | return nil; |
| 230 | | SExp m = is_macro(car(x)); |
| 231 | | if (!nilp(m)) { |
| 232 | | return compile_macro_apply(m, x, e, next); |
| 233 | | } else { |
| 234 | | SExp op = car(x); |
| 235 | | if (eq(op, intern("quote"))) { |
| 236 | | SExp obj = cadr(x); |
| 237 | | return list(3, CONSTANT, obj, next); |
| 238 | | } else if (eq(op, intern("quasiquote"))) { |
| 239 | | SExp obj = cadr(x); |
| 240 | | SExp trans = transform_quasiquote(obj); |
| 241 | | return compile(trans, e, next); |
| 242 | | } else if (eq(op, intern("unquote"))) { |
| 243 | | compile_error(ERR_UNEXPECTED); |
| 244 | | return nil; |
| 245 | | } else if (eq(op, intern("unquote-splicing"))) { |
| 246 | | compile_error(ERR_UNEXPECTED); |
| 247 | | return nil; |
| 248 | | } else if (eq(op, intern("lambda"))) { |
| 249 | | SExp vars = cadr(x); |
| 250 | | SExp body = cddr(x); |
| 251 | | SExp rest, modified_vars; |
| 252 | | if (has_rest_param(&rest, &modified_vars, vars)) { |
| 253 | | return compile_lambda(rest, modified_vars, body, e, next); |
| 254 | | } else { |
| 255 | | return compile_lambda(nil, vars, body, e, next); |
| 256 | | } |
| 257 | | } else if (eq(op, intern("if"))) { |
| 258 | | SExp test = cadr(x); |
| 259 | | SExp then = caddr(x); |
| 260 | | SExp thenc = compile(then, e, next); |
| 261 | | SExp els, elsec; |
| 262 | | SExp ddd = cdddr(x); |
| 263 | | if (!nilp(ddd)) els = cadddr(x); |
| 264 | | else els = nil; |
| 265 | | elsec = compile(els, e, next); |
| 266 | | return compile(test, e, list(3, TEST, thenc, elsec)); |
| 267 | | } else if (eq(op, intern("set!"))) { |
| 268 | | SExp var = cadr(x); |
| 269 | | SExp xx = caddr(x); |
| 270 | | return compile_set(ASSIGN, var, xx, e, next, false); |
| 271 | | } else if (eq(op, intern("define"))) { |
| 272 | | SExp var = cadr(x); |
| 273 | | SExp body = cddr(x); |
| 274 | | return compile_define(var, body, e, next); |
| 275 | | } else if (eq(op, intern("call/cc"))) { |
| 276 | | SExp xx = cadr(x); |
| 277 | | SExp c = list(2, CONTI, list(2, ARGUMENT, compile(xx, e, cons(APPLY, nil)))); |
| 278 | | if (tailp(next)) |
| 279 | | return c; |
| 280 | | else |
| 281 | | return list(3, FRAME, c, next); |
| 282 | | } else if (eq(op, intern("defmacro"))) { |
| 283 | | SExp name = cadr(x); |
| 284 | | SExp vars = caddr(x); |
| 285 | | SExp body = cdddr(x); |
| 286 | | compile_defmacro(name, vars, body); |
| 287 | | return next; |
| 288 | | } else if (eq(op, intern("begin"))) { |
| 289 | | SExp body = cdr(x); |
| 290 | | if (nilp(body)) { |
| 291 | | return next; |
| 292 | | } else { |
| 293 | | return compile_block(body, e, next); |
| 294 | | } |
| 295 | | } else { |
| 296 | | return compile_pair_loop(cdr(x), compile(car(x), e, cons(APPLY, nil)), e, next); |
| 297 | | } |
| | 271 | SExp op = car(x); |
| | 272 | if (eq(op, intern("quote"))) { |
| | 273 | SExp obj = cadr(x); |
| | 274 | return list(3, CONSTANT, obj, next); |
| | 275 | } else if (eq(op, intern("lambda"))) { |
| | 276 | SExp vars = cadr(x); |
| | 277 | SExp body = caddr(x); |
| | 278 | SExp non_local = find_free(body, vars); |
| | 279 | SExp free = filter_member(append2(car(e), cdr(e)), non_local); |
| | 280 | SExp sets = find_sets(body, vars); |
| | 281 | |
| | 282 | SExp boxes = make_boxes(sets, vars, compile(body, cons(vars, free), set_union(sets, set_intersect(s, free)), list(2, RETURN, int2s(length(vars))))); |
| | 283 | return collect_free(free, e, list(4, CLOSE, int2s(length(free)), boxes, next)); |
| | 284 | } else if (eq(op, intern("if"))) { |
| | 285 | SExp test = cadr(x); |
| | 286 | SExp then = caddr(x); |
| | 287 | SExp thenc = compile(then, e, s, next); |
| | 288 | SExp els, elsec; |
| | 289 | SExp ddd = cdddr(x); |
| | 290 | if (!nilp(ddd)) els = cadddr(x); |
| | 291 | else els = nil; |
| | 292 | elsec = compile(els, e, s, next); |
| | 293 | return compile(test, e, s, list(3, TEST, thenc, elsec)); |
| | 294 | } else if (eq(op, intern("set!"))) { |
| | 295 | SExp var = cadr(x); |
| | 296 | SExp xx = caddr(x); |
| | 297 | |
| | 298 | int n; |
| | 299 | switch (compile_lookup(&n, var, e)) { |
| | 300 | default: assert(false); return nil; |
| | 301 | case VarLocal: return compile(xx, e, s, list(3, ASSIGN_LOCAL, int2s(n), next)); |
| | 302 | case VarFree: return compile(xx, e, s, list(3, ASSIGN_FREE, int2s(n), next)); |
| | 303 | case VarUndef: return compile(xx, e, s, list(3, ASSIGN_GLOBAL, var, next)); |
| | 304 | } |
| | 305 | } else if (eq(op, intern("call/cc"))) { |
| | 306 | int is_tail = tailp(next); |
| | 307 | SExp xx = cadr(x); |
| | 308 | SExp apply = list(1, APPLY); |
| | 309 | SExp nx = is_tail ? list(4, SHIFT, 1, cadr(next), apply) : apply; |
| | 310 | SExp c = list(2, CONTI, list(2, ARGUMENT, compile(xx, e, s, nx))); |
| | 311 | if (is_tail) |
| | 312 | return c; |
| | 313 | else |
| | 314 | return list(3, FRAME, c, next); |
| | 315 | } else if (eq(op, intern("define"))) { |
| | 316 | SExp var = cadr(x); |
| | 317 | SExp body = caddr(x); |
| | 318 | return compile(body, e, s, list(3, DEFINE, var, next)); |
| | 319 | } else { |
| | 320 | SExp args = cdr(x); |
| | 321 | SExp apply = list(1, APPLY); |
| | 322 | SExp nx = tailp(next) ? list(4, SHIFT, int2s(length(cdr(x))), cadr(next), apply) : apply; |
| | 323 | SExp c = compile(car(x), e, s, nx); |
| | 324 | return compile_pair_loop(args, c, e, s, next); |
![(please configure the [header_logo] section in trac.ini)](/share/chrome/site/your_project_logo.png){kind=logo}