add set!.

GNUmakefile

@@ -16,7 +16,7 @@ mes.h: mes.c GNUmakefile
 		while read f; do\
 			fun=$$(echo $$f | sed -e 's,^scm [*],,' -e 's,{.*,,');\
 			name=$$(echo $$fun | sed -e 's,^scm [\*],,' | grep -o '^[^ ]*');\
-			scm_name=$$(echo $$name | sed -e 's,_p$$,?,' -e 's,^builtin_,,' -re 's,(.*)_$$,c:\1,' | sed -e 's,^less?$$,<,' -e 's,^minus$$,-,' -e 's,_,-,g');\
+			scm_name=$$(echo $$name | sed -e 's,_p$$,?,' -e 's,_x$$,!,' -e 's,^builtin_,,' -re 's,(.*)_$$,c:\1,' | sed -e 's,^less?$$,<,' -e 's,^minus$$,-,' -e 's,_,-,g');\
 			args=$$(echo $$fun | grep -o 'scm [\*]' | wc -l);\
 			echo "scm *$$fun;";\
 			echo "scm scm_$$name = {FUNCTION$$args, .name=\"$$scm_name\", .function$$args=&$$name};";\

mes.c

@@ -69,6 +69,11 @@ typedef struct scm_t {
 #include "mes.h"
 
 scm *display_helper (scm*, bool, char*, bool);
+bool
+symbol_eq (scm *x, char *s)
+{
+  return x->type == ATOM && !strcmp (x->name, s);
+}
 
 scm scm_nil = {ATOM, "()"};
 scm scm_dot = {ATOM, "."};
@@ -86,7 +91,15 @@ scm scm_symbol_unquote = {ATOM, "unquote"};
 #if MACROS
 scm scm_macro = {ATOM, "*macro*"};
 #endif
+
+scm scm_symbol_EOF = {ATOM, "EOF"};
+scm scm_symbol_EOF2 = {ATOM, "EOF2"};
 scm scm_symbol_current_module = {ATOM, "current-module"};
+scm scm_symbol_define = {ATOM, "define"};
+scm scm_symbol_define_macro = {ATOM, "define-macro"};
+scm scm_symbol_eval = {ATOM, "eval"};
+scm scm_symbol_loop2 = {ATOM, "loop2"};
+scm scm_symbol_set_x = {ATOM, "set!"};
 
 // PRIMITIVES
 
@@ -147,9 +160,18 @@ pair_p (scm *x)
   return x->type == PAIR ? &scm_t : &scm_f;
 }
 
-scm *eval (scm*, scm*);
+scm *
+set_cdr_x (scm *x, scm *e)
+{
+  assert (x->type == PAIR);
+  x->cdr = e;
+}
 
-scm *display (scm*);
+scm *
+set_env_x (scm *x, scm *e, scm *a)
+{
+  return set_cdr_x (assoc (x, a), e);
+}
 
 scm *
 quote (scm *x)
@@ -301,6 +323,8 @@ eval_ (scm *e, scm *a)
         return cadr (e);
       if (car (e) == &scm_lambda)
         return e;
+      if (car (e) == &scm_symbol_set_x)
+        return set_env_x (cadr (e), eval (caddr (e), a), a);
 #if QUASIQUOTE
       else if (car (e) == &scm_symbol_unquote)
         return eval (cadr (e), a);
@@ -811,21 +835,23 @@ loop (scm *r, scm *e, scm *a)
 #endif
   if (e == &scm_nil)
     return r;
-  else if (eq_p (e, make_atom ("EOF")) == &scm_t)
-    return apply (cdr (assoc (make_atom ("loop2"), a)),
+  else if (eq_p (e, &scm_symbol_EOF) == &scm_t)
+    return apply (cdr (assoc (&scm_symbol_loop2, a)),
                   cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a);
-  else if (eq_p (e, make_atom ("EOF2")) == &scm_t)
+  else if (eq_p (e, &scm_symbol_EOF2) == &scm_t)
     return r;
   else if (atom_p (e) == &scm_t)
     return loop (eval (e, a), readenv (a), a);
-  else if (eq_p (car (e), make_atom ("define")) == &scm_t)
+  else if (eq_p (car (e), &scm_symbol_define) == &scm_t)
     return loop (&scm_unspecified,
                  readenv (a),
                  cons (define (e, a), a));
-  else if (eq_p (car (e), make_atom ("define-macro")) == &scm_t)
+  else if (eq_p (car (e), &scm_symbol_define_macro) == &scm_t)
     return loop (&scm_unspecified,
                  readenv (a),
                  cons (define_macro (e, a), a));
+  else if (eq_p (car (e), &scm_symbol_set_x) == &scm_t)
+    return loop (set_env_x (cadr (e), eval (caddr (e), a), a), readenv (a), a);
   return loop (eval (e, a), readenv (a), a);
 }
 
@@ -864,7 +890,7 @@ eval (scm *e, scm *a)
   puts ("");
 #endif
 
-  scm *eval__ = assoc (make_atom ("eval"), a);
+  scm *eval__ = assoc (&scm_symbol_eval, a);
   assert (eval__ != &scm_f);
   eval__ = cdr (eval__);
   if (builtin_p (eval__) == &scm_t

mes.mes

@@ -108,6 +108,15 @@
    ((eq? (car fn) 'label) (apply (caddr fn) x (cons (cons (cadr fn)
                                                          (caddr fn)) a)))))
 
+(define (begin-env body a)
+  (cond ((null? body) *unspecified*)
+        ((null? (cdr body)) (eval (car body) a))
+        (#t (eval (car body) a)
+            (begin-env (cdr body) a))))
+
+(define (set-env! x e a)
+  (set-cdr! (assoc x a) e))
+
 (define (eval e a)
   ;;(debug "eval e=~a a=~a\n" e a)
   ;;(debug "eval (atom? ~a)=~a\n" e (atom? e))
@@ -127,6 +136,7 @@
     (cond
      ((eq? (car e) 'quote) (cadr e))
      ((eq? (car e) 'lambda) e)
+     ((eq? (car e) 'set!) (set-env! (cadr e) (caddr e) a))
      ((eq? (car e) 'unquote) (eval (cadr e) a))
      ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) a))
      ((eq? (car e) 'cond) (evcon (cdr e) a))

scm.mes

@@ -48,13 +48,10 @@
          (loop2 *unspecified* (readenv a) (cons (scm-define e a) a)))
         ((eq? (car e) 'define-macro)
          (loop2 *unspecified* (readenv a) (cons (scm-define-macro e a) a)))
+        ((eq? (car e) 'set!)
+         (loop2 (set-cdr! (assoc (cadr e) a) (eval (caddr e) a)) (readenv a) a))
+        (#t (loop2 (eval e a) (readenv a) a))))
 
-        (#t (loop2 (eval e a) (readenv a) a))
-        ;;(#t (loop2 ((cdr (assoc 'eval a)) e a) (readenv a) a))
-        ))
-
-;;(display 'loop:read-loop2-exiting...)
-;;(newline)
 EOF
 
 (define (+ x y) (- x (- 0 y)))

test.mes

@@ -106,4 +106,12 @@
 (map (lambda (i a) (display i) (display ':) (display a) (newline)) '(1 2 3 4) '(a b c d))
 (newline)
 
+(define a 0)
+(display 'a=0:)
+(display a)
+(newline)
+(set! a 1)
+(display 'a=1:)
+(display a)
+(newline)
 '()