artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core: Make closure real type.

Browse source 
* 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)); else fprintf (f, "#\\%c", VALUE (x));
break; break;
} }
case CLOSURE:
{
fprintf (f, "#<procedure #f ");
display_ (f, (cadr (CLOSURE (x))));
fprintf (f, ">");
return cell_unspecified;
}
case MACRO: case MACRO:
fprintf (f, "(*macro* "); fprintf (f, "(*macro* ");
display_helper (f, g_cells[x].macro, cont, sep, quote); 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 NUMBER: fprintf (f, "%d", VALUE (x)); break;
case PAIR: 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) { if (car (x) == cell_circular) {
fprintf (f, "(*circ* . #-1#)"); fprintf (f, "(*circ* . #-1#)");
return cell_unspecified; return cell_unspecified;

96
mes.c
View file

@ -36,7 +36,7 @@ int MAX_ARENA_SIZE = 20000000;
int GC_SAFETY = 100; int GC_SAFETY = 100;
typedef int SCM; 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 (*function0_t) (void);
typedef SCM (*function1_t) (SCM); typedef SCM (*function1_t) (SCM);
typedef SCM (*function2_t) (SCM, SCM); typedef SCM (*function2_t) (SCM, SCM);
@ -66,6 +66,7 @@ typedef struct scm_t {
int value; int value;
int function; int function;
SCM cdr; SCM cdr;
SCM closure;
SCM macro; SCM macro;
SCM vector; SCM vector;
int hits; int hits;
@ -165,6 +166,7 @@ SCM r3 = 0; // param 3
#define NAME(x) g_cells[x].name #define NAME(x) g_cells[x].name
#define STRING(x) g_cells[x].string #define STRING(x) g_cells[x].string
#define TYPE(x) g_cells[x].type #define TYPE(x) g_cells[x].type
#define CLOSURE(x) g_cells[x].closure
#define MACRO(x) g_cells[x].macro #define MACRO(x) g_cells[x].macro
#define REF(x) g_cells[x].ref #define REF(x) g_cells[x].ref
#define VALUE(x) g_cells[x].value #define VALUE(x) g_cells[x].value
@ -392,47 +394,54 @@ eval_apply ()
return cons (r2, r1); return cons (r2, r1);
apply: apply:
if (TYPE (r1) != PAIR) switch (TYPE (r1))
{ {
if (TYPE (r1) == FUNCTION) return call (r1, r2); case FUNCTION: return call (r1, r2);
if (r1 == cell_symbol_call_with_values) case CLOSURE:
{
r1 = car (r2);
r2 = cadr (r2);
goto call_with_values;
}
if (r1 == cell_symbol_current_module) return r0;
}
else
switch (car (r1))
{ {
case cell_symbol_lambda: SCM cl = CLOSURE (r1);
{ SCM args = cadr (cl);
SCM args = cadr (r1); SCM body = cddr (cl);
SCM body = cddr (r1); SCM aa = cdar (cl);
SCM p = pairlis (args, r2, r0); aa = cdr (aa);
call_lambda (body, p, p, r0); SCM p = pairlis (args, r2, aa);
goto begin; call_lambda (body, p, aa, 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
} }
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); SCM e = eval_env (r1, r0);
char const* type = 0; char const* type = 0;
if (e == cell_f || e == cell_t) type = "bool"; if (e == cell_f || e == cell_t) type = "bool";
@ -471,7 +480,6 @@ eval_apply ()
case cell_symbol_begin: goto begin; case cell_symbol_begin: goto begin;
case cell_symbol_lambda: case cell_symbol_lambda:
return make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0)); 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_if: {r1=cdr (r1); goto label_if;}
case cell_symbol_set_x: { case cell_symbol_set_x: {
SCM x = eval_env (caddr (r1), r0); return set_env_x (cadr (r1), x, r0); 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) while (scan < g_free.value)
{ {
if (NTYPE (scan) == KEYWORD if (NTYPE (scan) == CLOSURE
|| NTYPE (scan) == KEYWORD
|| NTYPE (scan) == MACRO || NTYPE (scan) == MACRO
|| NTYPE (scan) == PAIR || NTYPE (scan) == PAIR
|| NTYPE (scan) == REF || NTYPE (scan) == REF
@ -940,7 +949,8 @@ gc_loop (SCM scan)
SCM car = gc_copy (g_news[scan].car); SCM car = gc_copy (g_news[scan].car);
gc_relocate_car (scan, car); gc_relocate_car (scan, car);
} }
if ((NTYPE (scan) == MACRO if ((NTYPE (scan) == CLOSURE
|| NTYPE (scan) == MACRO
|| NTYPE (scan) == PAIR || NTYPE (scan) == PAIR
|| NTYPE (scan) == VALUES) || NTYPE (scan) == VALUES)
&& g_news[scan].cdr) // allow for 0 terminated list of symbols && g_news[scan].cdr) // allow for 0 terminated list of symbols
@ -1099,7 +1109,7 @@ mes_environment () ///((internal))
SCM SCM
make_closure (SCM args, SCM body, SCM a) 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 SCM

4
module/mes/fluids.mes
View file

@ -31,8 +31,8 @@
) )
(define (env:escape-closure a n) (define (env:escape-closure a n)
(if (closure? (car a)) (if (= 0 n) a (if (eq? (caar a) '*closure*) (if (= 0 n) a
(env:escape-closure (cdr a) (- n 1))) (env:escape-closure (cdr a) (- n 1)))
(env:escape-closure (cdr a) n))) (env:escape-closure (cdr a) n)))
(define-macro (module-define! name value a) (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+) (set-cdr! (assq (quote *closure*) a) a+)
(car a+))) (car a+)))
(env:define (cons (cons (quote <cell:macro>) 3) (list)) (current-module)) (env:define (cons (cons (quote <cell:macro>) 4) (list)) (current-module))
(env:define (cons (cons (quote <cell:pair>) 5) (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 sexp:define) #f) (list)) (current-module))
(env:define (cons (cons (quote env:macro) #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)) (env:define (cons (cons (quote cons*) #f) (list)) (current-module))
@ -104,7 +104,7 @@
(quote ((current-module)))))) (quote ((current-module))))))
(current-module))) (current-module)) (current-module))) (current-module))
(define <cell:keyword> 2) (define <cell:keyword> 3)
(define (read) (define (read)
(read-word (read-byte) (list) (current-module))) (read-word (read-byte) (list) (current-module)))

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

@ -23,21 +23,23 @@
;;; Code: ;;; Code:
(define <cell:char> 0) (define <cell:char> 0)
(define <cell:function> 1) (define <cell:closure> 1)
(define <cell:keyword> 2) (define <cell:function> 2)
(define <cell:macro> 3) (define <cell:keyword> 3)
(define <cell:number> 4) (define <cell:macro> 4)
(define <cell:pair> 5) (define <cell:number> 5)
(define <cell:ref> 6) (define <cell:pair> 6)
(define <cell:special> 7) (define <cell:ref> 7)
(define <cell:string> 8) (define <cell:special> 8)
(define <cell:symbol> 9) (define <cell:string> 9)
(define <cell:values> 10) (define <cell:symbol> 10)
(define <cell:vector> 11) (define <cell:values> 11)
(define <cell:broken-heart> 12) (define <cell:vector> 12)
(define <cell:broken-heart> 13)
(define cell:type-alist (define cell:type-alist
(list (cons <cell:char> (quote <cell:char>)) (list (cons <cell:char> (quote <cell:char>))
(cons <cell:closure> (quote <cell:closure>))
(cons <cell:function> (quote <cell:function>)) (cons <cell:function> (quote <cell:function>))
(cons <cell:keyword> (quote <cell:keyword>)) (cons <cell:keyword> (quote <cell:keyword>))
(cons <cell:macro> (quote <cell:macro>)) (cons <cell:macro> (quote <cell:macro>))
@ -57,6 +59,9 @@
(define (char? x) (define (char? x)
(eq? (core:type x) <cell:char>)) (eq? (core:type x) <cell:char>))
(define (closure? x)
(eq? (core:type x) <cell:closure>))
(define (function? x) (define (function? x)
(eq? (core:type x) <cell:function>)) (eq? (core:type x) <cell:function>))
@ -75,8 +80,7 @@
(eq? (core:type x) <cell:pair>)) (eq? (core:type x) <cell:pair>))
(define (pair? x) (define (pair? x)
(and (eq? (core:type x) <cell:pair>) (eq? (core:type x) <cell:pair>))
(not (eq? (car x) '*closure*))))
(define (special? x) (define (special? x)
(eq? (core:type x) <cell:special>)) (eq? (core:type x) <cell:special>))
@ -99,9 +103,6 @@
;; (define (null? x) ;; (define (null? x)
;; (eq? x '())) ;; (eq? x '()))
(define (closure? x)
(and (eq? (core:type x) <cell:pair>) (eq? (car x) '*closure*)))
(define (atom? x) (define (atom? x)
(not (pair? x))) (not (pair? x)))