core: Make closure real type.
* display.c (display_helper): * mes.c (type_t): Add CLOSURE. (scm_t): Add closure. (CLOSURE): New macro. (eval_apply:apply): Update. (eval_apply:eval): Remove closure special-casing. (gc_loop): Handle CLOSURE. * module/mes/read-0.mes: Update types. * module/mes/type-0.mes: Update types. * display.c (display): Update. * module/mes/fluids.mes (env:escape-closure): Check for '*closure.
This commit is contained in:
Jan Nieuwenhuizen
parent
20eecdc638
commit
20b7a7851a
13
display.c
13
display.c
|
|
@ -70,6 +70,13 @@ display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
|
|||
else fprintf (f, "#\\%c", VALUE (x));
|
||||
break;
|
||||
}
|
||||
case CLOSURE:
|
||||
{
|
||||
fprintf (f, "#<procedure #f ");
|
||||
display_ (f, (cadr (CLOSURE (x))));
|
||||
fprintf (f, ">");
|
||||
return cell_unspecified;
|
||||
}
|
||||
case MACRO:
|
||||
fprintf (f, "(*macro* ");
|
||||
display_helper (f, g_cells[x].macro, cont, sep, quote);
|
||||
|
|
@ -78,12 +85,6 @@ display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
|
|||
case NUMBER: fprintf (f, "%d", VALUE (x)); break;
|
||||
case PAIR:
|
||||
{
|
||||
if (car (x) == cell_closure) {
|
||||
fprintf (f, "#<procedure #f ");
|
||||
display_ (f, (caddr (x)));
|
||||
fprintf (f, ">");
|
||||
return cell_unspecified;
|
||||
}
|
||||
if (car (x) == cell_circular) {
|
||||
fprintf (f, "(*circ* . #-1#)");
|
||||
return cell_unspecified;
|
||||
|
|
|
|||
96
mes.c
96
mes.c
|
|
@ -36,7 +36,7 @@ int MAX_ARENA_SIZE = 20000000;
|
|||
int GC_SAFETY = 100;
|
||||
|
||||
typedef int SCM;
|
||||
enum type_t {CHAR, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
|
||||
enum type_t {CHAR, CLOSURE, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
|
||||
typedef SCM (*function0_t) (void);
|
||||
typedef SCM (*function1_t) (SCM);
|
||||
typedef SCM (*function2_t) (SCM, SCM);
|
||||
|
|
@ -66,6 +66,7 @@ typedef struct scm_t {
|
|||
int value;
|
||||
int function;
|
||||
SCM cdr;
|
||||
SCM closure;
|
||||
SCM macro;
|
||||
SCM vector;
|
||||
int hits;
|
||||
|
|
@ -165,6 +166,7 @@ SCM r3 = 0; // param 3
|
|||
#define NAME(x) g_cells[x].name
|
||||
#define STRING(x) g_cells[x].string
|
||||
#define TYPE(x) g_cells[x].type
|
||||
#define CLOSURE(x) g_cells[x].closure
|
||||
#define MACRO(x) g_cells[x].macro
|
||||
#define REF(x) g_cells[x].ref
|
||||
#define VALUE(x) g_cells[x].value
|
||||
|
|
@ -392,47 +394,54 @@ eval_apply ()
|
|||
return cons (r2, r1);
|
||||
|
||||
apply:
|
||||
if (TYPE (r1) != PAIR)
|
||||
switch (TYPE (r1))
|
||||
{
|
||||
if (TYPE (r1) == FUNCTION) return call (r1, r2);
|
||||
if (r1 == cell_symbol_call_with_values)
|
||||
{
|
||||
r1 = car (r2);
|
||||
r2 = cadr (r2);
|
||||
goto call_with_values;
|
||||
}
|
||||
if (r1 == cell_symbol_current_module) return r0;
|
||||
}
|
||||
else
|
||||
switch (car (r1))
|
||||
case FUNCTION: return call (r1, r2);
|
||||
case CLOSURE:
|
||||
{
|
||||
case cell_symbol_lambda:
|
||||
{
|
||||
SCM args = cadr (r1);
|
||||
SCM body = cddr (r1);
|
||||
SCM p = pairlis (args, r2, r0);
|
||||
call_lambda (body, p, p, r0);
|
||||
goto begin;
|
||||
}
|
||||
case cell_closure:
|
||||
{
|
||||
SCM args = caddr (r1);
|
||||
SCM body = cdddr (r1);
|
||||
SCM aa = cdadr (r1);
|
||||
aa = cdr (aa);
|
||||
SCM p = pairlis (args, r2, aa);
|
||||
call_lambda (body, p, aa, r0);
|
||||
goto begin;
|
||||
}
|
||||
#if BOOT
|
||||
case cell_symbol_label:
|
||||
{
|
||||
r0 = cons (cons (cadr (r1), caddr (r1)), r0);
|
||||
r1 = caddr (r1);
|
||||
goto apply;
|
||||
}
|
||||
#endif
|
||||
SCM cl = CLOSURE (r1);
|
||||
SCM args = cadr (cl);
|
||||
SCM body = cddr (cl);
|
||||
SCM aa = cdar (cl);
|
||||
aa = cdr (aa);
|
||||
SCM p = pairlis (args, r2, aa);
|
||||
call_lambda (body, p, aa, r0);
|
||||
goto begin;
|
||||
}
|
||||
case SYMBOL:
|
||||
{
|
||||
if (r1 == cell_symbol_call_with_values)
|
||||
{
|
||||
r1 = car (r2);
|
||||
r2 = cadr (r2);
|
||||
goto call_with_values;
|
||||
}
|
||||
if (r1 == cell_symbol_current_module) return r0;
|
||||
break;
|
||||
}
|
||||
case PAIR:
|
||||
{
|
||||
switch (car (r1))
|
||||
{
|
||||
case cell_symbol_lambda:
|
||||
{
|
||||
SCM args = cadr (r1);
|
||||
SCM body = cddr (r1);
|
||||
SCM p = pairlis (args, r2, r0);
|
||||
call_lambda (body, p, p, r0);
|
||||
goto begin;
|
||||
}
|
||||
#if BOOT
|
||||
case cell_symbol_label:
|
||||
{
|
||||
r0 = cons (cons (cadr (r1), caddr (r1)), r0);
|
||||
r1 = caddr (r1);
|
||||
goto apply;
|
||||
}
|
||||
#endif
|
||||
}
|
||||
}
|
||||
}
|
||||
SCM e = eval_env (r1, r0);
|
||||
char const* type = 0;
|
||||
if (e == cell_f || e == cell_t) type = "bool";
|
||||
|
|
@ -471,7 +480,6 @@ eval_apply ()
|
|||
case cell_symbol_begin: goto begin;
|
||||
case cell_symbol_lambda:
|
||||
return make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
|
||||
case cell_closure: return r1;
|
||||
case cell_symbol_if: {r1=cdr (r1); goto label_if;}
|
||||
case cell_symbol_set_x: {
|
||||
SCM x = eval_env (caddr (r1), r0); return set_env_x (cadr (r1), x, r0);
|
||||
|
|
@ -928,7 +936,8 @@ gc_loop (SCM scan)
|
|||
{
|
||||
while (scan < g_free.value)
|
||||
{
|
||||
if (NTYPE (scan) == KEYWORD
|
||||
if (NTYPE (scan) == CLOSURE
|
||||
|| NTYPE (scan) == KEYWORD
|
||||
|| NTYPE (scan) == MACRO
|
||||
|| NTYPE (scan) == PAIR
|
||||
|| NTYPE (scan) == REF
|
||||
|
|
@ -940,7 +949,8 @@ gc_loop (SCM scan)
|
|||
SCM car = gc_copy (g_news[scan].car);
|
||||
gc_relocate_car (scan, car);
|
||||
}
|
||||
if ((NTYPE (scan) == MACRO
|
||||
if ((NTYPE (scan) == CLOSURE
|
||||
|| NTYPE (scan) == MACRO
|
||||
|| NTYPE (scan) == PAIR
|
||||
|| NTYPE (scan) == VALUES)
|
||||
&& g_news[scan].cdr) // allow for 0 terminated list of symbols
|
||||
|
|
@ -1099,7 +1109,7 @@ mes_environment () ///((internal))
|
|||
SCM
|
||||
make_closure (SCM args, SCM body, SCM a)
|
||||
{
|
||||
return cons (cell_closure, cons (cons (cell_circular, a), cons (args, body)));
|
||||
return make_cell (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
|
|||
|
|
@ -31,8 +31,8 @@
|
|||
)
|
||||
|
||||
(define (env:escape-closure a n)
|
||||
(if (closure? (car a)) (if (= 0 n) a
|
||||
(env:escape-closure (cdr a) (- n 1)))
|
||||
(if (eq? (caar a) '*closure*) (if (= 0 n) a
|
||||
(env:escape-closure (cdr a) (- n 1)))
|
||||
(env:escape-closure (cdr a) n)))
|
||||
|
||||
(define-macro (module-define! name value a)
|
||||
|
|
|
|||
|
|
@ -43,8 +43,8 @@
|
|||
(set-cdr! (assq (quote *closure*) a) a+)
|
||||
(car a+)))
|
||||
|
||||
(env:define (cons (cons (quote <cell:macro>) 3) (list)) (current-module))
|
||||
(env:define (cons (cons (quote <cell:pair>) 5) (list)) (current-module))
|
||||
(env:define (cons (cons (quote <cell:macro>) 4) (list)) (current-module))
|
||||
(env:define (cons (cons (quote <cell:pair>) 6) (list)) (current-module))
|
||||
(env:define (cons (cons (quote sexp:define) #f) (list)) (current-module))
|
||||
(env:define (cons (cons (quote env:macro) #f) (list)) (current-module))
|
||||
(env:define (cons (cons (quote cons*) #f) (list)) (current-module))
|
||||
|
|
@ -104,7 +104,7 @@
|
|||
(quote ((current-module))))))
|
||||
(current-module))) (current-module))
|
||||
|
||||
(define <cell:keyword> 2)
|
||||
(define <cell:keyword> 3)
|
||||
|
||||
(define (read)
|
||||
(read-word (read-byte) (list) (current-module)))
|
||||
|
|
|
|||
|
|
@ -23,21 +23,23 @@
|
|||
;;; Code:
|
||||
|
||||
(define <cell:char> 0)
|
||||
(define <cell:function> 1)
|
||||
(define <cell:keyword> 2)
|
||||
(define <cell:macro> 3)
|
||||
(define <cell:number> 4)
|
||||
(define <cell:pair> 5)
|
||||
(define <cell:ref> 6)
|
||||
(define <cell:special> 7)
|
||||
(define <cell:string> 8)
|
||||
(define <cell:symbol> 9)
|
||||
(define <cell:values> 10)
|
||||
(define <cell:vector> 11)
|
||||
(define <cell:broken-heart> 12)
|
||||
(define <cell:closure> 1)
|
||||
(define <cell:function> 2)
|
||||
(define <cell:keyword> 3)
|
||||
(define <cell:macro> 4)
|
||||
(define <cell:number> 5)
|
||||
(define <cell:pair> 6)
|
||||
(define <cell:ref> 7)
|
||||
(define <cell:special> 8)
|
||||
(define <cell:string> 9)
|
||||
(define <cell:symbol> 10)
|
||||
(define <cell:values> 11)
|
||||
(define <cell:vector> 12)
|
||||
(define <cell:broken-heart> 13)
|
||||
|
||||
(define cell:type-alist
|
||||
(list (cons <cell:char> (quote <cell:char>))
|
||||
(cons <cell:closure> (quote <cell:closure>))
|
||||
(cons <cell:function> (quote <cell:function>))
|
||||
(cons <cell:keyword> (quote <cell:keyword>))
|
||||
(cons <cell:macro> (quote <cell:macro>))
|
||||
|
|
@ -57,6 +59,9 @@
|
|||
(define (char? x)
|
||||
(eq? (core:type x) <cell:char>))
|
||||
|
||||
(define (closure? x)
|
||||
(eq? (core:type x) <cell:closure>))
|
||||
|
||||
(define (function? x)
|
||||
(eq? (core:type x) <cell:function>))
|
||||
|
||||
|
|
@ -75,8 +80,7 @@
|
|||
(eq? (core:type x) <cell:pair>))
|
||||
|
||||
(define (pair? x)
|
||||
(and (eq? (core:type x) <cell:pair>)
|
||||
(not (eq? (car x) '*closure*))))
|
||||
(eq? (core:type x) <cell:pair>))
|
||||
|
||||
(define (special? x)
|
||||
(eq? (core:type x) <cell:special>))
|
||||
|
|
@ -99,9 +103,6 @@
|
|||
;; (define (null? x)
|
||||
;; (eq? x '()))
|
||||
|
||||
(define (closure? x)
|
||||
(and (eq? (core:type x) <cell:pair>) (eq? (car x) '*closure*)))
|
||||
|
||||
(define (atom? x)
|
||||
(not (pair? x)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue