diff options
| -rw-r--r-- | lisplib.c | 3 | ||||
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 76 | ||||
| -rw-r--r-- | share/txr/stdlib/error.tl | 9 |
3 files changed, 81 insertions, 7 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("bind-mac-error"), lit("lambda-too-many-args"), + lit("lambda-too-few-args"), lit("lambda-short-apply-list"), nil }; val name[] = { diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index d4609e01..4d37b9b5 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -882,12 +882,21 @@ (let ((gopcode [%gcall-op% sym]) (opcode [%call-op% sym])) (tree-case (car args) - ((op arg) (if (and (eq op 'fun) (bindable arg)) - (let ((fbind env.(lookup-fun arg))) - me.(comp-call-impl oreg env (if fbind opcode gopcode) - (if fbind fbind.loc me.(get-fidx arg)) - (cdr args))) - :)) + ((op arg . more) + (caseq op + (fun (cond + (more (compile-error form "excess args in fun form")) + ((bindable arg) + (let ((fbind env.(lookup-fun arg))) + me.(comp-call-impl oreg env (if fbind opcode gopcode) + (if fbind fbind.loc me.(get-fidx arg)) + (cdr args)))) + ((and (consp arg) (eq (car arg) 'lambda)) + me.(comp-fun-form oreg env ^(sym ,arg ,*(cdr args)))) + (t :))) + (lambda me.(comp-inline-lambda oreg env opcode + (car args) (cdr args))) + (t :))) (arg me.(comp-call oreg env (if (eq sym 'usr:apply) 'apply sym) args))))) (ift me.(comp-ift oreg env form)) @@ -924,6 +933,17 @@ [reduce-left uni afrags nil .fvars] [reduce-left uni afrags nil .ffuns])))) +(defmeth compiler comp-inline-lambda (me oreg env opcode lambda args) + (let ((reg-args args) apply-list-arg) + (when (eql opcode 'apply) + (unless args + (compile-error lambda "apply requires arguments")) + (set reg-args (butlast args) + apply-list-arg (car (last args)))) + me.(compile oreg env (expand (lambda-apply-transform lambda + reg-args + apply-list-arg))))) + (defmeth compiler comp-for (me oreg env form) (mac-param-bind form (op inits (: test . rets) incs . body) form (let* ((treg me.(alloc-treg)) @@ -1308,6 +1328,50 @@ (mac-param-bind form (op name def) form ^(sys:rt-defsymacro ',name ',def))) +(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr) + (mac-param-bind lm-expr (lambda lm-args . lm-body) lm-expr + (let* ((pars (new (fun-param-parser lm-args lm-expr))) + (ign-sym (gensym)) + (al-val (gensym))) + ^(let* ,(build + (while (and fix-arg-exprs pars.req) + (add ^(,(pop pars.req) ,(pop fix-arg-exprs)))) + (while (and fix-arg-exprs pars.opt) + (add ^(,(car (pop pars.opt)) ,(pop fix-arg-exprs)))) + (cond + ((and (null fix-arg-exprs) + (null pars.req) + (null pars.opt)) + (when (or pars.rest apply-list-expr) + (add ^(,(or pars.rest ign-sym) ,apply-list-expr)))) + (fix-arg-exprs + (lambda-too-many-args lm-expr)) + (apply-list-expr + (add ^(,al-val ,apply-list-expr)) + (when pars.req + (add ^(,ign-sym (if (< (len ,al-val) ,(len pars.req)) + (lambda-short-apply-list))))) + (while pars.req + (add ^(,(pop pars.req) (pop ,al-val)))) + (while pars.opt + (add ^(,(caar pars.opt) + (if ,al-val + (pop ,al-val) + ,(cadar pars.opt)))) + (pop pars.opt)) + (when pars.rest + (add ^(,pars.rest ,al-val)))) + (pars.req + (lambda-too-few-args lm-expr)) + (pars.opt + (while pars.opt + (add ^(,(caar pars.opt) + ,(cadar pars.opt))) + (pop pars.opt)) + (when pars.rest + (add ^(,pars.rest)))))) + ,*lm-body)))) + (defun usr:compile-toplevel (exp) (let ((co (new compiler)) (as (new assembler))) diff --git a/share/txr/stdlib/error.tl b/share/txr/stdlib/error.tl index b58c93f9..b632fd64 100644 --- a/share/txr/stdlib/error.tl +++ b/share/txr/stdlib/error.tl @@ -54,3 +54,12 @@ obj params) (compile-error ctx-form "object ~s too ~a for params ~s" obj (if too-few-p "short" "long") params))) + +(defun lambda-too-many-args (form) + (compile-error form "excess arguments given")) + +(defun lambda-too-few-args (form) + (compile-error form "inufficient arguments given")) + +(defun lambda-short-apply-list () + (throwf 'eval-error "~s: applied argument list too short" 'lambda)) |