From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Holger Peters Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 1/1] Preserve source properties in unparse-tree-il Date: Fri, 30 Oct 2020 17:00:48 +0100 Message-ID: References: Mime-Version: 1.0 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="17287"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Holger Peters To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Fri Oct 30 17:03:44 2020 Return-path: Envelope-to: guile-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1kYWsR-0004JT-01 for guile-devel@m.gmane-mx.org; Fri, 30 Oct 2020 17:03:43 +0100 Original-Received: from localhost ([::1]:56528 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kYWsQ-0004nr-12 for guile-devel@m.gmane-mx.org; Fri, 30 Oct 2020 12:03:42 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:44634) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kYWqY-0003Bd-5l for guile-devel@gnu.org; Fri, 30 Oct 2020 12:01:46 -0400 Original-Received: from mout01.posteo.de ([185.67.36.65]:48314) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kYWqV-0005CE-QI for guile-devel@gnu.org; Fri, 30 Oct 2020 12:01:45 -0400 Original-Received: from submission (posteo.de [89.146.220.130]) by mout01.posteo.de (Postfix) with ESMTPS id 9087D160062 for ; Fri, 30 Oct 2020 17:01:26 +0100 (CET) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=posteo.de; s=2017; t=1604073686; bh=rx5HA9wzX2fswB25HdWo6avBQe5vXuzIR1SurbIGNlc=; h=From:To:Cc:Subject:Date:From; b=ef639D2T0VZWZes/4g9bj+Zhy4/NmF6QdBh8LfKvpONGnx2FJqRd7NN+i6RqXbFKg AzhJpFJrRIYXq4PRaIRqLZreFYbZv3amPBZidADbAgbYKjJ/7AtCYJyZa/T/C4jikK /tX5bWeO7swGypRyWGd3HYe/cCui/GQ49/skP+bp9V2fUspKH+iHK2RxMA3TTHXl00 aEp56Bl7IDnmr4+GGgeZpWlbFxl5eByQJTfLtIxp9Nu4F8MQ1O2ug4cPlIBpR8X/M6 yXfFJiMTPr0a6y0uVtMmgD0Y6S34mI4p2eTdQje83nzv+onBsWwIUvLKjaMh/56DqQ n6EtRDGYl7D9Q== Original-Received: from customer (localhost [127.0.0.1]) by submission (posteo.de) with ESMTPSA id 4CN6Vt05xQz6tmF; Fri, 30 Oct 2020 17:01:25 +0100 (CET) X-Mailer: git-send-email 2.28.0 In-Reply-To: Received-SPF: pass client-ip=185.67.36.65; envelope-from=holger.peters@posteo.de; helo=mout01.posteo.de X-detected-operating-system: by eggs.gnu.org: First seen = 2020/10/30 11:46:34 X-ACL-Warn: Detected OS = Linux 3.11 and newer [fuzzy] X-Spam_score_int: -43 X-Spam_score: -4.4 X-Spam_bar: ---- X-Spam_report: (-4.4 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, RCVD_IN_DNSWL_MED=-2.3, RCVD_IN_MSPIKE_H4=0.001, RCVD_IN_MSPIKE_WL=0.001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-Mailman-Approved-At: Fri, 30 Oct 2020 12:03:27 -0400 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.23 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Original-Sender: "guile-devel" Xref: news.gmane.io gmane.lisp.guile.devel:20607 Archived-At: * module/language/tree-il.scm (unparse-tree-il): Add source properties if available. * module/language/tree-il.scm (add-src-loc): New procedure. --- module/language/tree-il.scm | 75 +++++++++++++++++++++---------------- 1 file changed, 42 insertions(+), 33 deletions(-) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 974fce29e..732edaf19 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -256,84 +256,93 @@ (else (error "unrecognized tree-il" exp))))) +(define (add-src-loc src-loc expr) + "Annotate expression with source location" + (when src-loc + (set-source-properties! expr src-loc)) + expr) + (define (unparse-tree-il tree-il) (match tree-il (($ src) '(void)) (($ src proc args) - `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) + (add-src-loc src `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))) (($ src name args) - `(primcall ,name ,@(map unparse-tree-il args))) + (add-src-loc src `(primcall ,name ,@(map unparse-tree-il args)))) (($ src test consequent alternate) - `(if ,(unparse-tree-il test) - ,(unparse-tree-il consequent) - ,(unparse-tree-il alternate))) + (add-src-loc src `(if ,(unparse-tree-il test) + ,(unparse-tree-il consequent) + ,(unparse-tree-il alternate)))) (($ src name) - `(primitive ,name)) + (add-src-loc src `(primitive ,name))) (($ src name gensym) - `(lexical ,name ,gensym)) + (add-src-loc src `(lexical ,name ,gensym))) (($ src name gensym exp) - `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) + (add-src-loc `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))) (($ src mod name public?) - `(,(if public? '@ '@@) ,mod ,name)) + (add-src-loc `(,(if public? '@ '@@) ,mod ,name))) (($ src mod name public? exp) - `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) + (add-src-loc `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)) )) (($ src mod name) - `(toplevel ,name)) + (add-src-loc src `(toplevel ,name) )) (($ src mod name exp) - `(set! (toplevel ,name) ,(unparse-tree-il exp))) + (add-src-loc src `(set! (toplevel ,name) ,(unparse-tree-il exp)))) (($ src mod name exp) - `(define ,name ,(unparse-tree-il exp))) + (add-src-loc src `(define ,name ,(unparse-tree-il exp)))) (($ src meta body) - (if body - `(lambda ,meta ,(unparse-tree-il body)) - `(lambda ,meta (lambda-case)))) + (let ((res (if body + `(lambda ,meta ,(unparse-tree-il body)) + `(lambda ,meta (lambda-case))))) + (add-src-loc src res))) (($ src req opt rest kw inits gensyms body alternate) - `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms) - ,(unparse-tree-il body)) - . ,(if alternate (list (unparse-tree-il alternate)) '()))) - + (let ((res `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms) + ,(unparse-tree-il body)) + . ,(if alternate (list (unparse-tree-il alternate)) '())))) + (add-src-loc src res))) + (($ src exp) - `(const ,exp)) + (add-src-loc src `(const ,exp))) (($ src head tail) - `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail))) + (add-src-loc src `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))) (($ src names gensyms vals body) - `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + (add-src-loc `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)) )) (($ src in-order? names gensyms vals body) - `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms - ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + (add-src-loc src `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms + ,(map unparse-tree-il vals) ,(unparse-tree-il body)))) (($ src names gensyms vals body) - `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + (add-src-loc src `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))) (($ src exp body) - `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) + (add-src-loc src `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))) (($ src escape-only? tag body handler) - `(prompt ,escape-only? - ,(unparse-tree-il tag) - ,(unparse-tree-il body) - ,(unparse-tree-il handler))) + (add-src-loc src `(prompt ,escape-only? + ,(unparse-tree-il tag) + ,(unparse-tree-il body) + ,(unparse-tree-il handler)))) (($ src tag args tail) - `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args) - ,(unparse-tree-il tail))))) + (add-src-loc `(abort ,(unparse-tree-il tag) + ,(map unparse-tree-il args) + ,(unparse-tree-il tail)))))) (define* (tree-il->scheme e #:optional (env #f) (opts '())) (values ((@ (language scheme decompile-tree-il) -- 2.28.0