symbol-function, symbol-value and fun become places.

* eval.c (op_setqf): New function.
(eval_init): Register sys:setqf operator. Also expose
global variable hash tables via sys:top-vb and sys:top-fb.

* place.tl (sys:get-fb, sys:get-vb): New functions.
(fun, symbol-function, symbol-value): New places defined.

3 files changed, 77 insertions, 0 deletions

diff --git a/ChangeLog b/ChangeLog
index 64854228..8238480c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2015-05-22  Kaz Kylheku  <kaz@kylheku.com>
+
+	symbol-function, symbol-value and fun become places.
+
+	* eval.c (op_setqf): New function.
+	(eval_init): Register sys:setqf operator. Also expose
+	global variable hash tables via sys:top-vb and sys:top-fb.
+
+	* place.tl (sys:get-fb, sys:get-vb): New functions.
+	(fun, symbol-function, symbol-value): New places defined.
+
 2015-05-21  Kaz Kylheku  <kaz@kylheku.com>
 
 	Introduce defparm operator.
diff --git a/eval.c b/eval.c
index ebcd2db0..908a8b20 100644
--- a/eval.c
+++ b/eval.c
@@ -1710,6 +1710,22 @@ static val op_lisp1_value(val form, val env)
   }
 }
 
+static val op_setqf(val form, val env)
+{
+  val args = rest(form);
+  val var = pop(&args);
+  val newval = pop(&args);
+
+  if (!bindable(var)) {
+    eval_error(form, lit("sys:setqf: ~s is not a bindable symbol"), var, nao);
+  } else {
+    val binding = lookup_fun(env, var);
+    if (nilp(binding))
+      eval_error(form, lit("unbound function ~s"), var, nao);
+    return sys_rplacd(binding, eval(newval, env, form));
+  }
+}
+
 static val op_for(val form, val env)
 {
   val forsym = first(form);
@@ -3940,6 +3956,7 @@ void eval_init(void)
   reg_op(setq_s, op_setq);
   reg_op(intern(lit("lisp1-setq"), system_package), op_lisp1_setq);
   reg_op(intern(lit("lisp1-value"), system_package), op_lisp1_value);
+  reg_op(intern(lit("setqf"), system_package), op_setqf);
   reg_op(for_s, op_for);
   reg_op(for_star_s, op_for);
   reg_op(dohash_s, op_dohash);
@@ -4404,6 +4421,8 @@ void eval_init(void)
   reg_fun(intern(lit("make-like"), user_package), func_n2(make_like));
   reg_fun(intern(lit("nullify"), user_package), func_n1(nullify));
 
+  reg_var(intern(lit("top-vb"), system_package), top_vb);
+  reg_var(intern(lit("top-fb"), system_package), top_fb);
   reg_fun(intern(lit("symbol-value"), user_package), func_n1(symbol_value));
   reg_fun(intern(lit("symbol-function"), user_package), func_n1(symbol_function));
   reg_fun(intern(lit("boundp"), user_package), func_n1(boundp));
diff --git a/place.tl b/place.tl
index 85b0a55f..086f2708 100644
--- a/place.tl
+++ b/place.tl
@@ -481,6 +481,53 @@
                             (progn (errno ,val-sym) ,val-sym)))))
           ,body)))
 
+   (defplace (fun sym) body
+     (getter setter
+       ^(macrolet ((,getter () ^(fun ,',sym))
+                   (,setter (val) ^(sys:setqf ,',sym ,val)))
+          ,*body))
+     :
+     (deleter
+       ^(macrolet ((,deleter (:env env)
+                      (when (lexical-fun-p env ',sym)
+                        (sys:eval-err "~s is a lexical function, \
+                                      \ thus not deletable"
+                                    ',sym))
+                       ^(fmakunbound ',',sym)))
+          ,*body)))
+
+   (defun sys:get-fb (sym)
+     (or (gethash sys:top-fb sym)
+         (sys:eval-err "unbound function ~s" sym)))
+
+   (defplace (symbol-function sym-expr) body
+     (getter setter
+       (with-gensyms (binding-sym)
+         ^(let ((,binding-sym (sys:get-fb ,sym-expr)))
+             (macrolet ((,getter () ^(cdr ,',binding-sym))
+                        (,setter (val) ^(sys:rplacd ,',binding-sym ,val)))
+               ,*body))))
+     :
+     (deleter
+       ^(macrolet ((,deleter () ^(fmakunbound ,',sym-expr)))
+          ,*body)))
+
+   (defun sys:get-vb (sym)
+     (or (gethash sys:top-vb sym)
+         (sys:eval-err "unbound variable ~s" sym)))
+
+   (defplace (symbol-value sym-expr) body
+     (getter setter
+       (with-gensyms (binding-sym)
+         ^(let ((,binding-sym (sys:get-vb ,sym-expr)))
+             (macrolet ((,getter () ^(cdr ,',binding-sym))
+                        (,setter (val) ^(sys:rplacd ,',binding-sym ,val)))
+               ,*body))))
+     :
+     (deleter
+       ^(macrolet ((,deleter () ^(makunbound ,',sym-expr)))
+          ,*body)))
+
    (macro-time
      (each ((from '(car cdr))
             (to '(first rest)))