summaryrefslogtreecommitdiffstats
path: root/stdlib
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2023-03-20 22:39:18 -0700
committerKaz Kylheku <kaz@kylheku.com>2023-03-20 22:39:18 -0700
commit6afa38a542e99165defe54e5d303abb51c65167c (patch)
tree6167c85e3c9a752cd91094c08cd74b37eab2a155 /stdlib
parent6cdcff2307016b9f828d3101dc7302729a99b948 (diff)
downloadtxr-6afa38a542e99165defe54e5d303abb51c65167c.tar.gz
txr-6afa38a542e99165defe54e5d303abb51c65167c.tar.bz2
txr-6afa38a542e99165defe54e5d303abb51c65167c.zip
compiler: source-loc propagation in tree-bind, lambda
Unused variables in tree-bind forms are not generating diagnostics with source location info. We are missing some rlcp calls. * stdlib/compiler.tl (compiler comp-catch): The generated lambda here ends up transformed to a let by the lambda-apply-transfom function. We must propagate source info to it, otherwise unused catch clause parameters get diagnosed without it. (compiler (comp-for, comp-mac-param-bind, comp-mac-env-param-bind, comp-tree-case): Confer source location info onto the err-form argument of expand-bind-mac-params. (expand-bind-mac-params): Pass source location info from err-form onto the generated let* form. Thus, diagnostics related to variables in that let* get reported against that form's location. (lambda-apply-transform): Pass source location info from the lambda expression to the generated let. * stdlib/except.tl (usr:catch): Pass source loc info from each clause source code to the transformed clause. The transformed clause will turn into a lambda which will turn into a let in comp-catch, and then into a let in lambda-apply-transform.
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/compiler.tl181
-rw-r--r--stdlib/except.tl3
2 files changed, 95 insertions, 89 deletions
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index b6fbc6c4..fcfa1d67 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -920,8 +920,9 @@
(cfrags (collect-each ((cl clauses)
(i (range 1)))
(mac-param-bind form (sym params . body) cl
- (let* ((cl-src ^(apply (lambda ,params ,*body)
- ,ex-sym-var ,ex-args-var))
+ (let* ((cl-src (rlcp-tree ^(apply (lambda ,params ,*body)
+ ,ex-sym-var ,ex-args-var)
+ form))
(cfrag me.(compile oreg nenv (expand cl-src)))
(lskip (gensym "l")))
(new (frag oreg
@@ -1550,8 +1551,8 @@
(with-gensyms (obj-var)
(let ((expn (expand ^(let ((,obj-var ,obj))
,(expand-bind-mac-params ^',form
- ^',(rlcp ^(,(car form))
- form)
+ (rlcp-tree ^'(,(car form))
+ form)
params nil
obj-var t nil body)))))
me.(compile oreg env expn)))))
@@ -1562,7 +1563,8 @@
(let ((expn (expand ^(let* ((,obj-var ,obj)
(,form-var ,context))
,(expand-bind-mac-params form-var
- form-var
+ (rlcp-tree ^'(,(car form))
+ form)
params nil
obj-var t nil body)))))
me.(compile oreg env expn)))))
@@ -1573,7 +1575,8 @@
(let ((expn (expand ^(let* ((,obj-var ,obj)
(,form-var ,context))
,(expand-bind-mac-params form-var
- form-var
+ (rlcp-tree ^'(,(car form))
+ form)
params menv
obj-var t nil body)))))
me.(compile oreg env expn)))))
@@ -1587,7 +1590,7 @@
(err-blk (gensym))
(lout (gensym "l"))
(ctx-form ^',form)
- (err-form ^',(rlcp ^(,(car form)) form))
+ (err-form (rlcp-tree ^'(,(car form)) form))
(treg me.(maybe-alloc-treg oreg))
(objfrag me.(compile treg env obj))
(cfrags (collect-each ((c cases)
@@ -2038,8 +2041,9 @@
(expand-rec params obj-var nil)
(when stmt
(push ^(,(gensym) (progn ,*(nreverse stmt))) vars))
- ^(let* (,*gen-stk ,*(nreverse vars))
- ,*body))))
+ (rlcp ^(let* (,*gen-stk ,*(nreverse vars))
+ ,*body)
+ err-form))))
(defun expand-defvarl (form)
(mac-param-bind form (op sym : value) form
@@ -2111,85 +2115,86 @@
(if pars.rest (list pars.rest)))))
(or (isecp all-vars fix-arg-iter)
(member apply-list-expr all-vars)))))
- ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-iter)
- (let* ,(build
- (if apply-list-expr
- (add ^(,al-val ,apply-list-expr)))
- (while (and fix-vals pars.req)
- (add ^(,(pop pars.req) ,(pop fix-vals)))
- (pop fix-arg-iter))
- (while (and fix-vals pars.opt)
- (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
- (add ^(,var-sym ,(car fix-vals)))
- (if have-sym
- (add ^(,have-sym t)))
- (unless (and (safe-constantp (car fix-arg-iter))
- (neq (safe-const-eval (car fix-arg-iter))
- :))
- (push (list* var-sym have-sym init-form) check-opts)))
- (pop fix-vals)
- (pop fix-arg-iter))
- (cond
- ((and (null pars.req)
- (null pars.opt))
- (if fix-vals
- (if pars.rest
- (add ^(,pars.rest
- (list*
- ,*(nthcdr pars.nfix
- ^(,*fix-arg-exprs ,apply-list-expr)))))
- (lambda-too-many-args lm-expr))
- (cond
- ((and pars.rest apply-list-expr)
- (add ^(,pars.rest ,al-val)))
- (pars.rest
- (add ^(,pars.rest nil)))
- (apply-list-expr
- (add ^(,ign-2 (if ,al-val
- (lambda-excess-apply-list))))))))
- ((and fix-vals apply-list-expr)
- (lambda-too-many-args lm-expr))
- (apply-list-expr
- (when pars.req
- (add ^(,ign-1 (if (< (len ,al-val) ,(len pars.req))
- (lambda-short-apply-list)))))
- (while pars.req
- (add ^(,(pop pars.req) (pop ,al-val))))
- (while pars.opt
- (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
- (cond
- (have-sym
- (add ^(,var-sym (if ,al-val
- (car ,al-val)
- ,init-form)))
- (add ^(,have-sym (when ,al-val
- (pop ,al-val)
- t))))
- (t (add ^(,var-sym (if ,al-val
- (pop ,al-val)
- ,init-form)))))
- (push (list* var-sym have-sym init-form) check-opts)))
- (if pars.rest
- (add ^(,pars.rest ,al-val))
- (add ^(,ign-2 (if ,al-val
- (lambda-excess-apply-list))))))
- (pars.req
- (lambda-too-few-args lm-expr))
- (pars.opt
- (while pars.opt
- (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
- (add ^(,var-sym ,init-form))
- (if have-sym
- (add ^(,have-sym)))))
- (when pars.rest
- (add ^(,pars.rest))))))
- ,*(mapcar (tb ((var-sym have-sym . init-form))
- ^(when (eq ,var-sym :)
- (set ,var-sym ,init-form)
- ,*(if have-sym
- ^((set ,have-sym nil)))))
- (nreverse check-opts))
- ,*lm-body))))))
+ (rlcp ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-iter)
+ (let* ,(build
+ (if apply-list-expr
+ (add ^(,al-val ,apply-list-expr)))
+ (while (and fix-vals pars.req)
+ (add ^(,(pop pars.req) ,(pop fix-vals)))
+ (pop fix-arg-iter))
+ (while (and fix-vals pars.opt)
+ (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
+ (add ^(,var-sym ,(car fix-vals)))
+ (if have-sym
+ (add ^(,have-sym t)))
+ (unless (and (safe-constantp (car fix-arg-iter))
+ (neq (safe-const-eval (car fix-arg-iter))
+ :))
+ (push (list* var-sym have-sym init-form) check-opts)))
+ (pop fix-vals)
+ (pop fix-arg-iter))
+ (cond
+ ((and (null pars.req)
+ (null pars.opt))
+ (if fix-vals
+ (if pars.rest
+ (add ^(,pars.rest
+ (list*
+ ,*(nthcdr pars.nfix
+ ^(,*fix-arg-exprs ,apply-list-expr)))))
+ (lambda-too-many-args lm-expr))
+ (cond
+ ((and pars.rest apply-list-expr)
+ (add ^(,pars.rest ,al-val)))
+ (pars.rest
+ (add ^(,pars.rest nil)))
+ (apply-list-expr
+ (add ^(,ign-2 (if ,al-val
+ (lambda-excess-apply-list))))))))
+ ((and fix-vals apply-list-expr)
+ (lambda-too-many-args lm-expr))
+ (apply-list-expr
+ (when pars.req
+ (add ^(,ign-1 (if (< (len ,al-val) ,(len pars.req))
+ (lambda-short-apply-list)))))
+ (while pars.req
+ (add ^(,(pop pars.req) (pop ,al-val))))
+ (while pars.opt
+ (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
+ (cond
+ (have-sym
+ (add ^(,var-sym (if ,al-val
+ (car ,al-val)
+ ,init-form)))
+ (add ^(,have-sym (when ,al-val
+ (pop ,al-val)
+ t))))
+ (t (add ^(,var-sym (if ,al-val
+ (pop ,al-val)
+ ,init-form)))))
+ (push (list* var-sym have-sym init-form) check-opts)))
+ (if pars.rest
+ (add ^(,pars.rest ,al-val))
+ (add ^(,ign-2 (if ,al-val
+ (lambda-excess-apply-list))))))
+ (pars.req
+ (lambda-too-few-args lm-expr))
+ (pars.opt
+ (while pars.opt
+ (tree-bind (var-sym : init-form have-sym) (pop pars.opt)
+ (add ^(,var-sym ,init-form))
+ (if have-sym
+ (add ^(,have-sym)))))
+ (when pars.rest
+ (add ^(,pars.rest))))))
+ ,*(mapcar (tb ((var-sym have-sym . init-form))
+ ^(when (eq ,var-sym :)
+ (set ,var-sym ,init-form)
+ ,*(if have-sym
+ ^((set ,have-sym nil)))))
+ (nreverse check-opts))
+ ,*lm-body))
+ lm-expr)))))
(defun orig-form (form)
(whilet ((anc (macro-ancestor form)))
diff --git a/stdlib/except.tl b/stdlib/except.tl
index e5938873..08402dd6 100644
--- a/stdlib/except.tl
+++ b/stdlib/except.tl
@@ -34,7 +34,8 @@
(tree-bind (args-ex . body-ex)
(sys:expand-params args body
e nil form)
- ^(,type (,(gensym) ,*args-ex) ,*body-ex)))
+ (rlcp ^(,type (,(gensym) ,*args-ex) ,*body-ex)
+ @1)))
catch-clauses)))
^(sys:catch ,catch-syms ,try-form nil ,*sys-catch-clauses)))