From: No Itisnt <theseaisinhere@gmail.com>
To: guile-devel <guile-devel@gnu.org>
Subject: [PATCH] Allow printing of malformed tree-il
Date: Fri, 2 Jul 2010 19:32:07 -0500 [thread overview]
Message-ID: <AANLkTiluPuTObi4V9wPnkWgad64JLBD0aQj9KbD-XXDW@mail.gmail.com> (raw)
[-- 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
next reply other threads:[~2010-07-03 0:32 UTC|newest]
Thread overview: 5+ messages / expand[flat|nested] mbox.gz Atom feed top
2010-07-03 0:32 No Itisnt [this message]
2010-07-08 10:16 ` [PATCH] Allow printing of malformed tree-il Andy Wingo
2010-07-09 6:23 ` No Itisnt
2010-07-17 12:11 ` Andy Wingo
2010-07-17 19:25 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=AANLkTiluPuTObi4V9wPnkWgad64JLBD0aQj9KbD-XXDW@mail.gmail.com \
--to=theseaisinhere@gmail.com \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).