andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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 2016-12-23 18:48:36 +01:00
parent 20eecdc638
commit 20b7a7851a
5 changed files with 83 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
display.c
View File

@ -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
View File

@ -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

4
module/mes/fluids.mes
View File

@ -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)

6
module/mes/read-0.mes
View File

@ -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)))

35
module/mes/type-0.mes
View File

@ -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)))