From 43a3a326b7df58e3f5058ecaf37b9d492a270ec1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 May 2009 13:02:42 +0000 Subject: [PATCH] hash quasiquote on hash tables (PR 10266) (merge to 4.2) svn: r15003 --- collects/scheme/private/qq-and-or.ss | 30 ++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/collects/scheme/private/qq-and-or.ss b/collects/scheme/private/qq-and-or.ss index 61df94fe76..4cf2ab610c 100644 --- a/collects/scheme/private/qq-and-or.ss +++ b/collects/scheme/private/qq-and-or.ss @@ -341,7 +341,7 @@ (list (quote-syntax quote) (prefab-struct-key (syntax-e x))) l2)))) - ;; hash or hasheq + ;; hash[eq[v]] (if (if (syntax? x) (hash? (syntax-e x)) #f) @@ -349,15 +349,29 @@ (((qq-hash-assocs) (lambda (x level) (if (null? x) - (quote-syntax ()) + x (let-values (((pair) (car x))) - (apply-cons - (list (quote-syntax list*) - (list (quote-syntax quote) - (datum->syntax here (car pair))) - (qq (datum->syntax here (cdr pair)) level)) - (qq-hash-assocs (cdr x) level))))))) + (let-values ([(val) + (qq (datum->syntax here (cdr pair)) level)] + [(rest) + (qq-hash-assocs (cdr x) level)]) + (if (if (eq? val (cdr pair)) + (eq? rest (cdr x)) + #f) + x + (apply-cons + (list (quote-syntax list*) + (list (quote-syntax quote) + (datum->syntax here (car pair))) + (if (eq? val (cdr pair)) + (list (quote-syntax quote) + val) + val)) + (if (eq? rest (cdr x)) + (list (quote-syntax quote) + rest) + rest))))))))) (let-values (((l0) (hash-map (syntax-e x) cons))) (let-values (((l) (qq-hash-assocs l0 level)))