Skip to content

Commit

Permalink
let-values: avoid rebinding, better declarations
Browse files Browse the repository at this point in the history 
the let* equivalents now avoid rebinding at the end which can avoid
unused variable warnings in cases where a binding is only used by later
bindings.

It now uses process-declarations to do the declaration processing

Also some fixes to the sysdcls which had got out of date
  • Loading branch information
@tfeb
tfeb committed Jan 8, 2025
1 parent a1fab80 commit 3aac7bf
Show file tree
Hide file tree
Showing 5 changed files with 106 additions and 74 deletions.
4 changes: 2 additions & 2 deletions README.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2575,7 +2575,7 @@ Declarations should be handled properly (`(declare (type fixnum ...))` is better

In the `let*`-style cases the declarations will apply to all duplicate variables.

`special` declarations are an interesting case for sequenctial binding forms. Consider this form:
`special` declarations are an interesting case for sequential binding forms. Consider this form:

```lisp
(let*-values (((a) 1)
Expand All @@ -2587,7 +2587,7 @@ In the `let*`-style cases the declarations will apply to all duplicate variables
Now, without knowing what `f` does, it could refer to the dynamic binding of `a`. So the special declaration for `a` needs to be made for the temporary binding as well, unless it is in the final group of bindings. The starred forms now do this.

### Package, module, dependencies
`let-values` lives in and provides `:org.tfeb.hax.let-values`. It requires `spam`, `collecting`, `iterate` and `utilities`, and will attempt to load them if `require-module` is present.
`let-values` lives in and provides `:org.tfeb.hax.let-values`. It requires `spam`, `collecting`, `iterate` `utilities` and `process-declarations`, and will attempt to load them if `require-module` is present.

## Processing declaration specifiers: `process-declarations`
When writing macros it's useful to be able to process declaration specifiers in a standardised way. In particular it's common to want to select all specifiers which mention a variable and perhaps create equivalent ones which refer to some new variable introduced by the macro.
Expand Down
2 changes: 1 addition & 1 deletion VERSION
View file
Original file line number Diff line number Diff line change
@@ -1 +1 @@
10.0.0
10.1.0
163 changes: 94 additions & 69 deletions let-values.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,15 +6,17 @@
(:org.tfeb.hax.spam :compile t)
(:org.tfeb.hax.collecting :compile t)
(:org.tfeb.hax.iterate :compile t)
(:org.tfeb.hax.utilities :compile t))
(:org.tfeb.hax.utilities :compile t)
(:org.tfeb.hax.process-declarations :compile t))

(defpackage :org.tfeb.hax.let-values
(:use :cl)
(:use
:org.tfeb.hax.spam
:org.tfeb.hax.collecting
:org.tfeb.hax.iterate
:org.tfeb.hax.utilities)
:org.tfeb.hax.utilities
:org.tfeb.hax.process-declarations)
(:export
#:let-values
#:let*-values
Expand All @@ -25,6 +27,14 @@

(provide :org.tfeb.hax.let-values)

(define-condition let-values-error (program-error simple-error)
())

(defun let-values-error (control &rest arguments)
(error 'let-values-error
:format-control control
:format-arguments arguments))

(defun make-vme (name starred)
(cons name (if starred name (make-symbol (symbol-name name)))))

Expand All @@ -34,47 +44,52 @@
(defun vme-hidden (vme)
(cdr vme))

(defun mapped-variable-declarations (declarations varmap environment special-too)
;; Appropriate variable declarations from DECLARATIONS mapped
;; through VARMAP 'Appropriate' means type declarations and
(defun mapped-variable-declarations (declarations varmap environment special-too complement)
;; Return the appropriate variable declarations from DECLARATIONS
;; mapped through VARMAP. With COMPLEMENT return the complement of
;; this set. 'Appropriate' means type declarations and
;; dynamic-extent declarations. if SPECIAL-TOO is given also map
;; those (this matters for non-funal groups in sequential binding
;; constructs), since later initforms can refer to the special binding.
(flet ((mapped-variables (varmap variables)
(collecting
(dolist (vme varmap)
(when (member (vme-name vme) variables)
(collect (vme-hidden vme)))))))
(collecting
(dolist (declaration declarations)
(dolist (specifier (mapcar (lambda (d)
(canonicalize-declaration-specifier d environment))
(rest declaration)))
(destructuring-bind (identifier . rest) specifier
(case identifier
(type
(destructuring-bind (type . vars) rest
(let ((mapped-variables (mapped-variables varmap vars)))
(unless (null mapped-variables)
(collect `(declare (type ,type ,@mapped-variables)))))))
(dynamic-extent
(let ((mapped-variables (mapped-variables varmap rest)))
(unless (null mapped-variables)
(collect `(declare (,identifier ,@mapped-variables))))))
(special
(when special-too
(let ((mapped-variables (mapped-variables varmap rest)))
(unless (null mapped-variables)
(collect `(declare (special ,@mapped-variables))))))))))))))
;; those. This matters for non-final groups in sequential binding
;; constructs, since later initforms can refer to the special
;; binding.
(multiple-value-bind (selected others)
(with-collectors (select other)
(dolist (declaration declarations)
(dolist (specifier (rest declaration))
(processing-declaration-specifier (specifier :bindings ((variable-names '()))
:identifier identifier
:constructor maker
:environment environment)
(if (and (not (null variable-names))
(or special-too (not (eq identifier 'special))))
(multiple-value-bind (hits misses)
(with-collectors (hit miss)
(dolist (variable variable-names)
(let ((found (find variable varmap :key #'vme-name)))
(if found
(hit (vme-hidden found))
(miss variable)))))
(unless (null hits)
(select (maker :variable-names hits)))
(unless (null misses)
(other (maker :variable-names misses))))
(other specifier))))))
(if (not complement)
(if (not (null selected))
`((declare ,@selected))
'())
(if (not (null others))
`((declare ,@others))
'()))))

(defun expand-lv (clauses decls/forms starred environment &aux (unique-variables '()))
(unless (matchp clauses (list-of (some-of (list-matches (list-of (var)) (any))
(list-matches (list-of (var))))))
(error "bad clauses ~S" clauses))
(let-values-error "Bad let-values clauses ~S" (list clauses)))
(if (null clauses)
`(locally ,@decls/forms)
(multiple-value-bind (varmaps vfs)
(with-collectors (varmap vf)
(multiple-value-bind (varmaps vfs whole-varmap)
(with-collectors (varmap vf whole-varmap-entry)
(dolist (clause clauses)
(varmap
(with-collectors (vme)
Expand All @@ -83,25 +98,29 @@
(dolist (var vars)
(unless starred
(when (member var unique-variables)
(error "~S is not unique" var))
(let-values-error "Variable ~S is not unique" var))
(push var unique-variables))
(vme (make-vme var starred))))))))
(assert (= (length varmaps) (length vfs)) () "botched")
(let ((declarations (nth-value 0 (parse-simple-body decls/forms))))
(iterate mvb ((vms varmaps) (forms vfs))
(let ((vme (make-vme var starred)))
(vme vme) (whole-varmap-entry vme))))))))
(assert (= (length varmaps) (length vfs)) () "botched") ;our fault
(multiple-value-bind (declarations forms) (parse-simple-body decls/forms)
(iterate mvb ((vms varmaps) (initforms vfs))
(destructuring-bind (vm . more-vms) vms
(destructuring-bind (form . more-forms) forms
`(multiple-value-bind ,(mapcar #'vme-hidden vm) ,form
,@(mapped-variable-declarations declarations vm environment
(and starred (not (null more-vms))))
,(if (not (null more-vms))
(mvb more-vms more-forms)
`(let ,(mapcan (lambda (varmap)
(mapcar (lambda (vme)
`(,(vme-name vme) ,(vme-hidden vme)))
varmap))
varmaps)
,@decls/forms))))))))))
(destructuring-bind (initform . more-initforms) initforms
`(multiple-value-bind ,(mapcar #'vme-hidden vm) ,initform
,@(mapped-variable-declarations declarations vm environment starred nil)
,@(cond
((not (null more-vms))
`(,(mvb more-vms more-initforms)))
((not starred)
`((let ,(mapcar (lambda (vme)
`(,(vme-name vme) ,(vme-hidden vme)))
whole-varmap)
,@declarations
,@forms)))
(starred
`(,@(mapped-variable-declarations declarations whole-varmap environment t t)
,@forms)))))))))))

(defmacro let-values ((&rest clauses) &body decls/forms &environment environment)
"Multiple-value LET form with parallel binding
Expand Down Expand Up @@ -145,11 +164,11 @@ Declarations should be handled correctly and perhaps usefully."

(defun expand-lv* (clauses decls/forms starred environment &aux (unique-variables '()))
(unless (matchp clauses (list-of (list*-matches (list-of (var)) (any))))
(error "bad clauses ~S" clauses))
(let-values-error "bad let-values* clauses ~S" clauses))
(if (null clauses)
`(locally ,@decls/forms)
(multiple-value-bind (varmaps vis)
(with-collectors (varmap vi)
(multiple-value-bind (varmaps vis whole-varmap)
(with-collectors (varmap vi whole-varmap-entry)
(dolist (clause clauses)
(varmap
(with-collectors (vme)
Expand All @@ -158,25 +177,31 @@ Declarations should be handled correctly and perhaps usefully."
(dolist (var vars)
(unless starred
(when (member var unique-variables)
(error "~S is not unique" var))
(let-values-error "Variable ~S is not unique" var))
(push var unique-variables))
(vme (make-vme var starred))))))))
(assert (= (length varmaps) (length vis)) () "botched")
(let ((declarations (nth-value 0 (parse-simple-body decls/forms))))
(let ((vme (make-vme var starred)))
(vme vme) (whole-varmap-entry vme))))))))
(assert (= (length varmaps) (length vis)) () "botched") ;our fault
(multiple-value-bind (declarations forms) (parse-simple-body decls/forms)
(iterate mvc ((vms varmaps) (initforms vis))
(destructuring-bind (vm . more-vms) vms
(destructuring-bind (this-initforms . more-initforms) initforms
`(multiple-value-call
(lambda ,(mapcar #'vme-hidden vm)
,@(mapped-variable-declarations declarations vm environment nil)
,(if (not (null more-vms))
(mvc more-vms more-initforms)
`(let ,(mapcan (lambda (varmap)
(mapcar (lambda (vme)
`(,(vme-name vme) ,(vme-hidden vme)))
varmap))
varmaps)
,@decls/forms)))
,@(mapped-variable-declarations declarations vm environment starred nil)
,@(cond
((not (null more-vms))
`(,(mvc more-vms more-initforms)))
((not starred)
`((let ,(mapcar (lambda (vme)
`(,(vme-name vme) ,(vme-hidden vme)))
whole-varmap)
,@declarations
,@forms)))
(starred
`(,@(mapped-variable-declarations declarations whole-varmap environment
t t)
,@forms))))
,@this-initforms))))))))

(defmacro let-values* ((&rest clauses) &body decls/forms &environment environment)
Expand Down
8 changes: 7 additions & 1 deletion org.tfeb.hax.asd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,6 +40,11 @@
(:file "slog"
:depends-on ("simple-loops" "collecting" "spam"
"metatronic"))
(:file "let-values"
:depends-on ("spam" "collecting" "iterate"
"utilities" "process-declarations"))
(:file "process-declarations"
:depends-on ("utilities"))
(:file "hax-cometh"
:depends-on ("collecting" "wrapping-standard"
"iterate" "dynamic-state" "memoize"
Expand All @@ -48,7 +53,8 @@
"define-functions" "trace-macroexpand"
"binding" "stringtable" "object-accessors"
"utilities" "simple-loops" "spam"
"metatronic" "slog"))))
"metatronic" "slog" "let-values"
"process-declarations"))))

(defsystem "org.tfeb.hax/test"
:description "TFEB hax tests"
Expand Down
3 changes: 2 additions & 1 deletion org.tfeb.hax.let-values.asd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@
("org.tfeb.hax.spam"
"org.tfeb.hax.collecting"
"org.tfeb.hax.iterate"
"org.tfeb.hax.utilities")
"org.tfeb.hax.utilities"
"org.tfeb.hax.process-declarations")
:components
((:file "let-values")))

0 comments on commit 3aac7bf

Please sign in to comment.