* [PATCH] Allow printing of malformed tree-il
@ 2010-07-03 0:32 No Itisnt
2010-07-08 10:16 ` Andy Wingo
0 siblings, 1 reply; 5+ messages in thread
From: No Itisnt @ 2010-07-03 0:32 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 323 bytes --]
I've noticed while renovating my parser that it's pretty common for
unwanted values to weasel their way into tree-il. This patch adds an
optional else clause to unparse-tree-il, so when it's told to be
permissive, it will allow non-tree-il values through without error, so
as not to cause errors while printing errors etc.
[-- Attachment #2: 0001-Give-unparse-tree-il-an-optional-permissive-argument.patch --]
[-- Type: application/octet-stream, Size: 11541 bytes --]
From 2e92b99ad926036a1c8d21e36a05952faf8b0d39 Mon Sep 17 00:00:00 2001
From: No Itisnt <theseaisinhere+git@gmail.com>
Date: Fri, 2 Jul 2010 19:18:55 -0500
Subject: [PATCH] Give unparse-tree-il an optional permissive argument, so printing malformed
tree-il does not cause an error.
* module/language/tree-il.scm: unparse-tree-il now has an optional permissive
argument, and the tree-il printer specifies it as #t.
---
module/language/tree-il.scm | 136 ++++++++++++++++++++++--------------------
1 files changed, 71 insertions(+), 65 deletions(-)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 9cff011..07d2505 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,19 +1,19 @@
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
-;;;;
+;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
+;;;;
\f
(define-module (language tree-il)
@@ -47,7 +47,7 @@
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
<dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
- <dynref> dynref? make-dynref dynref-src dynref-fluid
+ <dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
@@ -62,7 +62,7 @@
pre-order!))
(define (print-tree-il exp port)
- (format port "#<tree-il ~a>" (unparse-tree-il exp)))
+ (format port "#<tree-il ~a>" (unparse-tree-il exp #t)))
(define-syntax borrow-core-vtables
(lambda (x)
@@ -134,7 +134,7 @@
(<dynset> fluid exp)
(<prompt> tag body handler)
(<abort> tag args tail))
-
+
\f
(define (location x)
@@ -195,7 +195,7 @@
(make-lambda loc meta (retrans body)))
((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate)
- (make-lambda-case loc req opt rest kw
+ (make-lambda-case loc req opt rest kw
(map retrans inits) gensyms
(retrans body)
(and=> alternate retrans)))
@@ -229,26 +229,26 @@
((dynwind ,winder ,body ,unwinder)
(make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
-
+
((dynlet ,fluids ,vals ,body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
-
+
((dynref ,fluid)
(make-dynref loc (retrans fluid)))
-
+
((dynset ,fluid ,exp)
(make-dynset loc (retrans fluid) (retrans exp)))
-
+
((prompt ,tag ,body ,handler)
(make-prompt loc (retrans tag) (retrans body) (retrans handler)))
-
+
((abort ,tag ,args ,tail)
(make-abort loc (retrans tag) (map retrans args) (retrans tail)))
(else
(error "unrecognized tree-il" exp)))))
-(define (unparse-tree-il tree-il)
+(define* (unparse-tree-il tree-il #:optional (permissive? #f))
(record-case tree-il
((<void>)
'(void))
@@ -313,23 +313,29 @@
((<dynwind> body winder unwinder)
`(dynwind ,(unparse-tree-il body)
,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))
-
+
((<dynlet> fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
,(unparse-tree-il body)))
-
+
((<dynref> fluid)
`(dynref ,(unparse-tree-il fluid)))
-
+
((<dynset> fluid exp)
`(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
-
+
((<prompt> tag body handler)
`(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))
-
+
((<abort> tag args tail)
`(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
- ,(unparse-tree-il tail)))))
+ ,(unparse-tree-il tail)))
+
+ (else
+ (if permissive?
+ tree-il
+ (error "unhandled record in tree-il" tree-il)))
+ ))
(define (tree-il->scheme e)
(record-case e
@@ -346,32 +352,32 @@
((<primitive-ref> name)
name)
-
+
((<lexical-ref> gensym)
gensym)
-
+
((<lexical-set> gensym exp)
`(set! ,gensym ,(tree-il->scheme exp)))
-
+
((<module-ref> mod name public?)
`(,(if public? '@ '@@) ,mod ,name))
-
+
((<module-set> mod name public? exp)
`(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
-
+
((<toplevel-ref> name)
name)
-
+
((<toplevel-set> name exp)
`(set! ,name ,(tree-il->scheme exp)))
-
+
((<toplevel-define> name exp)
`(define ,name ,(tree-il->scheme exp)))
-
+
((<lambda> meta body)
;; fixme: put in docstring
(tree-il->scheme body))
-
+
((<lambda-case> req opt rest kw inits gensyms body alternate)
(cond
((and (not opt) (not kw) (not alternate))
@@ -400,7 +406,7 @@
(restargs (if rest (list-ref gensyms (+ nreq nopt)) '()))
(reqargs (list-head gensyms nreq))
(optargs (if opt
- `(#:optional
+ `(#:optional
,@(map list
(list-head (list-tail gensyms nreq) nopt)
(map tree-il->scheme
@@ -432,13 +438,13 @@
(if (and (self-evaluating? exp) (not (vector? exp)))
exp
(list 'quote exp)))
-
+
((<sequence> exps)
`(begin ,@(map tree-il->scheme exps)))
-
+
((<let> gensyms vals body)
`(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
-
+
((<letrec> in-order? gensyms vals body)
`(,(if in-order? 'letrec* 'letrec)
,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
@@ -457,24 +463,24 @@
`(dynamic-wind ,(tree-il->scheme winder)
(lambda () ,(tree-il->scheme body))
,(tree-il->scheme unwinder)))
-
+
((<dynlet> fluids vals body)
`(with-fluids ,(map list
(map tree-il->scheme fluids)
(map tree-il->scheme vals))
,(tree-il->scheme body)))
-
+
((<dynref> fluid)
`(fluid-ref ,(tree-il->scheme fluid)))
-
+
((<dynset> fluid exp)
`(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp)))
-
+
((<prompt> tag body handler)
- `((@ (ice-9 control) prompt)
+ `((@ (ice-9 control) prompt)
,(tree-il->scheme tag) (lambda () ,(tree-il->scheme body))
,(tree-il->scheme handler)))
-
+
((<abort> tag args tail)
`(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args)
@@ -640,76 +646,76 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (conditional-test x) (lp test))
(set! (conditional-consequent x) (lp consequent))
(set! (conditional-alternate x) (lp alternate)))
-
+
((<lexical-set> name gensym exp)
(set! (lexical-set-exp x) (lp exp)))
-
+
((<module-set> mod name public? exp)
(set! (module-set-exp x) (lp exp)))
-
+
((<toplevel-set> name exp)
(set! (toplevel-set-exp x) (lp exp)))
-
+
((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp)))
-
+
((<lambda> body)
(set! (lambda-body x) (lp body)))
-
+
((<lambda-case> inits body alternate)
(set! inits (map lp inits))
(set! (lambda-case-body x) (lp body))
(if alternate
(set! (lambda-case-alternate x) (lp alternate))))
-
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
-
+
((<let> gensyms vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
-
+
((<letrec> gensyms vals body)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
-
+
((<fix> gensyms vals body)
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
-
+
((<let-values> exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
-
+
((<dynwind> body winder unwinder)
(set! (dynwind-body x) (lp body))
(set! (dynwind-winder x) (lp winder))
(set! (dynwind-unwinder x) (lp unwinder)))
-
+
((<dynlet> fluids vals body)
(set! (dynlet-fluids x) (map lp fluids))
(set! (dynlet-vals x) (map lp vals))
(set! (dynlet-body x) (lp body)))
-
+
((<dynref> fluid)
(set! (dynref-fluid x) (lp fluid)))
-
+
((<dynset> fluid exp)
(set! (dynset-fluid x) (lp fluid))
(set! (dynset-exp x) (lp exp)))
-
+
((<prompt> tag body handler)
(set! (prompt-tag x) (lp tag))
(set! (prompt-body x) (lp body))
(set! (prompt-handler x) (lp handler)))
-
+
((<abort> tag args tail)
(set! (abort-tag x) (lp tag))
(set! (abort-args x) (map lp args))
(set! (abort-tail x) (lp tail)))
-
+
(else #f))
-
+
(or (f x) x)))
(define (pre-order! f x)
@@ -727,7 +733,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<lexical-set> exp)
(set! (lexical-set-exp x) (lp exp)))
-
+
((<module-set> exp)
(set! (module-set-exp x) (lp exp)))
@@ -768,28 +774,28 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (dynwind-body x) (lp body))
(set! (dynwind-winder x) (lp winder))
(set! (dynwind-unwinder x) (lp unwinder)))
-
+
((<dynlet> fluids vals body)
(set! (dynlet-fluids x) (map lp fluids))
(set! (dynlet-vals x) (map lp vals))
(set! (dynlet-body x) (lp body)))
-
+
((<dynref> fluid)
(set! (dynref-fluid x) (lp fluid)))
-
+
((<dynset> fluid exp)
(set! (dynset-fluid x) (lp fluid))
(set! (dynset-exp x) (lp exp)))
-
+
((<prompt> tag body handler)
(set! (prompt-tag x) (lp tag))
(set! (prompt-body x) (lp body))
(set! (prompt-handler x) (lp handler)))
-
+
((<abort> tag args tail)
(set! (abort-tag x) (lp tag))
(set! (abort-args x) (map lp args))
(set! (abort-tail x) (lp tail)))
-
+
(else #f))
x)))
--
1.7.1.1
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Allow printing of malformed tree-il
2010-07-03 0:32 [PATCH] Allow printing of malformed tree-il No Itisnt
@ 2010-07-08 10:16 ` Andy Wingo
2010-07-09 6:23 ` No Itisnt
0 siblings, 1 reply; 5+ messages in thread
From: Andy Wingo @ 2010-07-08 10:16 UTC (permalink / raw)
To: No Itisnt; +Cc: guile-devel
Hi,
On Sat 03 Jul 2010 01:32, No Itisnt <theseaisinhere@gmail.com> writes:
> I've noticed while renovating my parser that it's pretty common for
> unwanted values to weasel their way into tree-il. This patch adds an
> optional else clause to unparse-tree-il, so when it's told to be
> permissive, it will allow non-tree-il values through without error, so
> as not to cause errors while printing errors etc.
Looks good; a couple of comments inline. If you want to kill trailing
whitespace, though, please do that as a separate commit, without any
functional changes
> -(define (unparse-tree-il tree-il)
> +(define* (unparse-tree-il tree-il #:optional (permissive? #f))
#f is the default value, there is no need to mention it explicitly.
> + (else
> + (if permissive?
> + tree-il
> + (error "unhandled record in tree-il" tree-il)))
> + ))
Here we should produce a warning, I think, even if we are
"permissive". Also please move the trailing parens to the previous
line.
Feel free to push when you have made these changes.
Cheers,
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Allow printing of malformed tree-il
2010-07-08 10:16 ` Andy Wingo
@ 2010-07-09 6:23 ` No Itisnt
2010-07-17 12:11 ` Andy Wingo
2010-07-17 19:25 ` Ludovic Courtès
0 siblings, 2 replies; 5+ messages in thread
From: No Itisnt @ 2010-07-09 6:23 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel
> Looks good; a couple of comments inline. If you want to kill trailing
> whitespace, though, please do that as a separate commit, without any
> functional changes
How do you reconcile that with 'delete-trailing-whitespace?
> Here we should produce a warning, I think, even if we are
> "permissive". Also please move the trailing parens to the previous
> line.
Is there a standard way to do this? Presumably it will be printed on
*current-warning-port*, but any specific formatting guidelines or
anything?
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Allow printing of malformed tree-il
2010-07-09 6:23 ` No Itisnt
@ 2010-07-17 12:11 ` Andy Wingo
2010-07-17 19:25 ` Ludovic Courtès
1 sibling, 0 replies; 5+ messages in thread
From: Andy Wingo @ 2010-07-17 12:11 UTC (permalink / raw)
To: No Itisnt; +Cc: guile-devel
On Fri 09 Jul 2010 08:23, No Itisnt <theseaisinhere@gmail.com> writes:
>> Looks good; a couple of comments inline. If you want to kill trailing
>> whitespace, though, please do that as a separate commit, without any
>> functional changes
>
> How do you reconcile that with 'delete-trailing-whitespace?
I don't, really. I don't use that mode. It's better to respect the
original source, so that the diffs and annotations aren't just noise...
Of course if you trawl through *my* commits, you would find
counter-examples to this "principle", so I guess there's a trade-off?
>> Here we should produce a warning, I think, even if we are
>> "permissive". Also please move the trailing parens to the previous
>> line.
>
> Is there a standard way to do this? Presumably it will be printed on
> *current-warning-port*, but any specific formatting guidelines or
> anything?
Unfortunately no guidelines, no. If you make some up, we'll use them
though :)
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Allow printing of malformed tree-il
2010-07-09 6:23 ` No Itisnt
2010-07-17 12:11 ` Andy Wingo
@ 2010-07-17 19:25 ` Ludovic Courtès
1 sibling, 0 replies; 5+ messages in thread
From: Ludovic Courtès @ 2010-07-17 19:25 UTC (permalink / raw)
To: guile-devel
Hi,
No Itisnt <theseaisinhere@gmail.com> writes:
>> Here we should produce a warning, I think, even if we are
>> "permissive". Also please move the trailing parens to the previous
>> line.
>
> Is there a standard way to do this? Presumably it will be printed on
> *current-warning-port*, but any specific formatting guidelines or
> anything?
Perhaps you could check whether (system base message) suits your needs
or can be otherwise extended. The purpose of this module was to
factorize all things related to compiler messages for the user; it’s
currently used only for compiler warnings.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 5+ messages in thread
end of thread, other threads:[~2010-07-17 19:25 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-07-03 0:32 [PATCH] Allow printing of malformed tree-il No Itisnt
2010-07-08 10:16 ` Andy Wingo
2010-07-09 6:23 ` No Itisnt
2010-07-17 12:11 ` Andy Wingo
2010-07-17 19:25 ` Ludovic Courtès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).