From 22e6568de7fe351974057e57d17078fd8f2b442b Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Fri, 22 May 2015 06:13:49 -0700 Subject: 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. --- ChangeLog | 11 +++++++++++ eval.c | 19 +++++++++++++++++++ place.tl | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 77 insertions(+) diff --git a/ChangeLog b/ChangeLog index 64854228..8238480c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2015-05-22 Kaz Kylheku + + 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 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))) -- cgit v1.2.3