diff options
| -rw-r--r-- | lisplib.c | 3 | ||||
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 171 | ||||
| -rw-r--r-- | share/txr/stdlib/error.tl | 11 |
3 files changed, 92 insertions, 93 deletions
@@ -544,7 +544,8 @@ static val pmac_instantiate(val set_fun) static val error_set_entries(val dlt, val fun) { val sys_name[] = { - lit("bind-mac-error"), lit("lambda-too-many-args"), + lit("bind-mac-error"), lit("bind-mac-check"), + lit("lambda-too-many-args"), lit("lambda-too-few-args"), lit("lambda-short-apply-list"), nil }; diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index a2adfa1e..3b04293f 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1244,101 +1244,88 @@ (defun expand-bind-mac-params (ctx-form err-form params menv-var obj-var strict err-block body) - (let (vars gen-stk (plen (gensym))) - (macrolet ((berr (too-few-p) - ^^(sys:bind-mac-error ,err-form ',params - ,obj-var ,',too-few-p))) - (labels ((get-gen () - (or (pop gen-stk) (gensym))) - (put-gen (g) - (push g gen-stk)) - (expand-rec (par-syntax obj-var) - (let* ((pars (new (mac-param-parser par-syntax ctx-form))) - (curs (get-gen))) - (unwind-protect - ^(,*(when strict - ^((set ,plen (if (consp ,obj-var) - (len ,obj-var) 0)))) - ,*(cond - ((eq strict t) - ^((if (< ,plen ,pars.nreq) - ,(berr t)) - ,*(unless pars.rest - ^((if (> ,plen ,pars.nfix) - ,(berr nil)))))) - ((null strict) nil) - ((symbolp strict) - ^((if (< ,plen ,pars.nreq) - (return-from ,err-block ',strict)) - ,*(unless pars.rest - ^((if (> ,plen ,pars.nfix) - (return-from ,err-block ',strict))))))) - ,*(append-each ((k pars.key)) - (tree-bind (key . sym) k - (push sym vars) - (caseq key - (:whole ^((set ,sym ,obj-var))) - (:form ^((set ,sym ,ctx-form))) - (:env ^((set ,sym ,menv-var)))))) - ,*(append-each ((p pars.req)) + (let (vars gen-stk (plen (if (and strict (neq strict t)) (gensym)))) + (labels ((get-gen () + (or (pop gen-stk) (gensym))) + (put-gen (g) + (push g gen-stk)) + (expand-rec (par-syntax obj-var) + (let* ((pars (new (mac-param-parser par-syntax ctx-form))) + (curs (get-gen))) + (unwind-protect + ^(,*(when plen + ^((set ,plen (if (consp ,obj-var) + (len ,obj-var) 0)))) + ,*(cond + ((eq strict t) + ^((sys:bind-mac-check ,err-form ',params + ,obj-var ,pars.nreq + ,(unless pars.rest pars.nfix)))) + ((null strict) nil) + ((symbolp strict) + (if pars.rest + ^((unless (<= ,pars.nreq ,plen) + (return-from ,err-block ',strict))) + ^((unless (<= ,pars.nreq ,plen ,pars.nfix) + (return-from ,err-block ',strict)))))) + ,*(append-each ((k pars.key)) + (tree-bind (key . sym) k + (push sym vars) + (caseq key + (:whole ^((set ,sym ,obj-var))) + (:form ^((set ,sym ,ctx-form))) + (:env ^((set ,sym ,menv-var)))))) + ,*(append-each ((p pars.req)) + (cond + ((listp p) + ^((set ,curs (car ,obj-var)) + (set ,obj-var (cdr ,obj-var)) + ,*(expand-rec p curs))) + (t + (push p vars) + ^((set ,p (car ,obj-var)) + (set ,obj-var (cdr ,obj-var)))))) + ,*(append-each ((o pars.opt)) + (tree-bind (p : init-form pres-p) o (cond ((listp p) - ^((set ,curs (car ,obj-var)) - (set ,obj-var (cdr ,obj-var)) - ,*(expand-rec p curs))) + (when pres-p + (push pres-p vars)) + ^((set ,curs (or (car ,obj-var) + (sys:upenv ,init-form))) + (cond + ((and ,obj-var + (prog1 + (neq (set ,curs (car ,obj-var)) :) + (set ,obj-var (cdr ,obj-var)))) + ,*(if pres-p + ^((set ,pres-p t)))) + (t + (set ,curs (sys:upenv ,init-form)))) + (when ,curs + ,*(expand-rec p curs)))) (t - (push p vars) - ^((set ,p (car ,obj-var)) - (set ,obj-var (cdr ,obj-var)))))) - ,*(append-each ((o pars.opt)) - (tree-bind (p : init-form pres-p) o - (cond - ((listp p) - (when pres-p - (push pres-p vars)) - ^((set ,curs (or (car ,obj-var) - (sys:upenv ,init-form))) - (cond - ((and ,obj-var - (prog1 - (neq (set ,curs (car ,obj-var)) :) - (set ,obj-var (cdr ,obj-var)))) - ,*(if pres-p - ^((set ,pres-p t)))) - (t - (set ,curs (sys:upenv ,init-form)))) - (when ,curs - ,*(expand-rec p curs)))) - (t - (push p vars) - (when pres-p - (push pres-p vars)) - ^((cond - ((and ,obj-var - (prog1 - (neq (set ,p (car ,obj-var)) :) - (set ,obj-var (cdr ,obj-var)))) - ,*(if pres-p - ^((set ,pres-p t)))) - (t - ,*(if init-form - ^((set ,p (sys:upenv ,init-form))))))))))) - ,*(when pars.rest - (push pars.rest vars) - ^((set ,pars.rest ,obj-var))) - ,*(unless pars.rest - (cond - ((eq strict t) - ^((if ,obj-var ,(berr nil)))) - ((null strict) nil) - ((symbolp strict) - ^((if ,obj-var - (return-from ,err-block ',strict))))))) - (put-gen curs))))) - (let ((bind-code (expand-rec params obj-var))) - ^(let (,*(nreverse vars) ,plen ,*gen-stk) - ,*bind-code - ,*body)))))) + (push p vars) + (when pres-p + (push pres-p vars)) + ^((cond + ((and ,obj-var + (prog1 + (neq (set ,p (car ,obj-var)) :) + (set ,obj-var (cdr ,obj-var)))) + ,*(if pres-p + ^((set ,pres-p t)))) + (t + ,*(if init-form + ^((set ,p (sys:upenv ,init-form))))))))))) + ,*(when pars.rest + (push pars.rest vars) + ^((set ,pars.rest ,obj-var)))) + (put-gen curs))))) + (let ((bind-code (expand-rec params obj-var))) + ^(let (,*(nreverse vars) ,*(if plen ^(,plen)) ,*gen-stk) + ,*bind-code + ,*body))))) (defun expand-defvarl (form) (mac-param-bind form (op sym : value) form diff --git a/share/txr/stdlib/error.tl b/share/txr/stdlib/error.tl index b632fd64..46fbb4eb 100644 --- a/share/txr/stdlib/error.tl +++ b/share/txr/stdlib/error.tl @@ -55,6 +55,17 @@ (compile-error ctx-form "object ~s too ~a for params ~s" obj (if too-few-p "short" "long") params))) +(defun sys:bind-mac-check (ctx-form params obj req fix) + (if (and obj (atom obj)) + (compile-error ctx-form "extra atom ~s not matched by params ~s" + obj params) + (let ((l (len obj))) + (iflet ((problem (cond + ((< l req) "short") + ((and fix (> l fix)) "short")))) + (compile-error ctx-form "object ~s too ~a for params ~s" + obj problem params))))) + (defun lambda-too-many-args (form) (compile-error form "excess arguments given")) |