Skip to content
Snippets Groups Projects
Commit ca408ac0 authored by Marco Antoniotti's avatar Marco Antoniotti :speech_balloon:
Browse files

Major cleanup, commenting and documenting.

parent 0c87beeb
Branches
No related merge requests found
Show whitespace changes
Inline Side-by-side
Showing
with 105 additions and 84 deletions
letv.lisp
+ 105
− 84
View file @ ca408ac0
......@@ -26,39 +26,33 @@
ids ::= <symbol> | '(' <symbol> + ')'
idtypes ::= <type designator> | '(' <type designator> + ')'
body ::= <form> *
body ::= [<declarations>] <form> *
|#
;;;
;;; Notes:
;;; 2023-03-09: The DECLARE declaration is not handled yet.
;;; TODO:
;;; 1. Fix parser to handle the DECLARE options and simplify the
;;; TYPE-SPECS handling.
;;; 2. Munge the declarations in LETV in order to ensure that they are
;;; wrapped in MAYBEs.
(in-package "LETV")
;;; just
;;; maybe
;;;
;;; These types are needed to get the semantics of LET and DECLARE
;;; right, given the expansion of LETV (see below), where each type
;;; declaration will have to be wrapped into a MAYBE.
;;;
;;; Very standard definitions.
(deftype just (ts) ts)
;;; parse-letv-vars-n-body
;;; Separates the variable specs from the body of the LETV/LETV* form.
(deftype maybe (ts) `(or null (just ,ts)))
(defun parse-letv-vars-n-body (vars-n-body)
(declare (type list vars-n-body))
(defun parse-letv-vars-n-body (vars-n-body)
;; A very kludgy and hatchet job.
;; We return two values: the "vars" and the "body"
(let* ((body (member 'in vars-n-body
(let* ((body (member "IN" vars-n-body
:key #'(lambda (e) (when (symbolp e) e))
:test #'string-equal))
(vars (ldiff vars-n-body body))
......@@ -67,9 +61,16 @@
))
;;; parse-letv-vars
;;; Parses the variables specifications for a LETV/LETV* form.
(defun parse-letv-vars (vars-specs
&aux vars forms type-specs declarations)
(declare (type list vars-spec)
(type list vars forms type-specs declarations)
(ignore declarations))
(labels ((start (vs)
(parse-vars vs))
......@@ -89,11 +90,13 @@
(push (second more-vars) type-specs)
(parse-vars (cddr more-vars)))
#| Unused FTTB
((and (symbolp (first more-vars))
(string-equal "DECLARE"
(first more-vars)))
(push (second more-vars) declarations)
(parse-vars (cddr more-vars)))
|#
(t
(push nil type-specs)
......@@ -104,6 +107,7 @@
(finish)))
)))
#| Unused FTTB
(parse-of-type (type-and-more)
(unless type-and-more ; Must begin with a <type spec>
(error "LETV/*: nothing after OF-TYPE."))
......@@ -139,6 +143,7 @@
(parse-vars (cddr type-and-more)))
))
)
|#
(finish ()
(values (nreverse vars)
......@@ -148,38 +153,8 @@
(start vars-specs)))
(defun build-letv-mvs-forms (mvs body)
(if (null mvs)
body
(destructuring-bind (mvars mvform mvtypes)
(first mvs)
`((multiple-value-bind ,mvars
,mvform
,@(when mvtypes
`((declare ,@(mapcar #'(lambda (v type)
`(type ,type ,v))
mvars
mvtypes)))
)
,@(build-letv-mvs-forms (rest mvs) body))))
))
(defun build-letv-vs-forms (vs body)
(if (null vs)
body
(loop for (v form ts) in vs
when ts
collect (list 'type ts v) into decls
end
collect (list v form) into bindings
finally
(return `(let ,bindings
,@(when decls
`((declare ,@decls)))
,@body)))
))
;;; build-par-binding-forms
;;; Builds the LET that is the translation of a LETV form.
(defun build-par-binding-forms (vars forms type-specs body)
(if (null vars)
......@@ -190,7 +165,7 @@
collect v into vbs
collect f into vfs
if (symbolp v)
when ts collect (list 'type ts v) into decls end
when ts collect `(type ,ts ,v) into decls end
else
if (listp v)
if (and ts (listp ts))
......@@ -202,7 +177,8 @@
into decls
else
if (and ts (not (listp ts)))
do (error "LETV/*: malformed type spec ~S in multiple-value spec." ts)
do (error "LETV/*: malformed type spec ~S in multiple-value spec."
ts)
end
end
else
......@@ -210,33 +186,28 @@
end
finally
(return
`(prog
,(loop for v in vbs
if (symbolp v)
collect v
else
append v)
,@(when decls
`((declare ,@decls)))
`(let ,(collect-vars vbs)
,@(if decls
`((locally (declare ,@decls)
,@(build-setq-stmts vbs vfs)
,@body)
,@body))
`(,@(build-setq-stmts vbs vfs)
,@body))
)
))
))
(defun check-vars (vars)
;; VARS comes from parse-letv-vars, therefore it is a list of
;; symbols and lists of symbols. A TYPE-ERROR is thrown if a
;; strange element is in the list.
;;
;; We traverse and collect duplicates and throw and error if there
;; are any.
;;; collect-vars
;;; Given the variable "bindings" of a LETV/LETV* form it "flattens"
;;; it. It also checks that every variable is actually a symbol and
;;; generated a TYPE-ERROR if it is not.
;; Simple, quadratic member-based loop. The assumption is that we
;; never have very long lists. Change to a HASH-TABLE if it gets too
;; slow.
(declaim (ftype (function (list) list) collect-vars))
(let ((vs (loop for v in vars
(defun collect-vars (vars)
(declare (type list vars))
(loop for v in vars
if (symbolp v)
collect v
else
......@@ -245,9 +216,32 @@
else do
(error 'type-error
:datum v
:expected-type '(or symbol list))))
)
(loop for (v . more-vs) on vs
:expected-type '(or symbol list))
end
))
;;; check-vars
;;; Traverses and collect duplicates in a list of variable "bindings"
;;; and throws and error if there are any.
(declaim (ftype (function (list) list) check-vars))
(defun check-vars (vars)
;; VARS comes from PARSE-LETV-VARS, therefore it is a list of
;; symbols and lists of symbols. A TYPE-ERROR is thrown by
;; COLLECT-VARS if a strange element is in the list.
;;
;; Simple, quadratic member-based loop. The assumption is that we
;; never have very long lists. Change to a HASH-TABLE if it gets too
;; slow.
(declare (type list vars))
(let ((vs (collect-vars vars)))
(declare (type list vs))
(loop for (v . more-vs) of-type (symbol . list) on vs
when (member v more-vs :test #'eq)
collect v into duplicates
finally
......@@ -256,14 +250,20 @@
(length duplicates)
duplicates))
)
t
vs
))
;;; build-setq-stmts
;;; Builds the interleaved sequence of PSETQs and MULTIPLE-VALUE-SETQs
;;; that initialize the variables introduced by LETV.
(defun build-setq-stmts (vars forms)
;; VARS and FORMS have the same length.
;; VARS contains symbols and lists o symbols (variables and multiple-values).
;; The result is a list of interleaved PSETQs and M-V-Bs.
(declare (type list vars forms))
(labels ((collect-setqs (vs fs collected-setqs)
(if (null vs)
collected-setqs ; Done.
......@@ -325,6 +325,15 @@
(defmacro letv (&body vars-n-body)
"Expands in a LET where each variable is initialized in a subsequent step.
The macro introduces a less verbose way to introduce bindings while
adopting a LOOP-like syntax.
Each variable is initialized by means of PSETQs and
MULTIPLE-VALUE-SETQs. Care is taken to mimic the semantic of LET and
to properly handle type declarations by means of LOCALLY.
"
(multiple-value-bind (vars body)
(parse-letv-vars-n-body vars-n-body)
(if vars
......@@ -332,11 +341,18 @@
(parse-letv-vars vars)
(build-par-binding-forms vars forms type-specs body)
)
`(progn ,@body))
`(block nil ,@body))
))
;;; build-seq-binding-forms
;;; Builds the nested sequence of LET* and M-V-Bs that are the
;;; expansion of a LETV form.
(defun build-seq-binding-forms (vars forms type-specs body)
(declare (type list vars forms type-specs))
(if (null vars)
body
(loop with mvb-form = nil
......@@ -385,11 +401,16 @@
(return mvb-form))
(t
(return '(progn)))
))))
(return `(progn)))
)
)))
(defmacro letv* (&body vars-n-body)
"Expands in a nested structure of LET*s and MULTIPLE-VALUE-BINDs.
The macro introduces a less verbose way to introduce bindings while
adopting a LOOP-like syntax."
(multiple-value-bind (vars body)
(parse-letv-vars-n-body vars-n-body)
(if vars
......@@ -397,7 +418,7 @@
(parse-letv-vars vars)
(build-seq-binding-forms vars forms type-specs body)
)
`(progn ,@body))
`(block nil ,@body))
))
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment