From 767766521cd6b4660d1aec6e61d6f80239d8c543 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 9 Feb 2009 15:27:51 +0000 Subject: [PATCH] infix for literal prefab structs, quasiquote unquoting in value positions of hash-table literals, and related changes (v4.1.4.3) svn: r13504 --- collects/drscheme/private/debug.ss | 2 + collects/scheme/private/qq-and-or.ss | 30 +++++- collects/scribblings/reference/reader.scrbl | 5 +- collects/scribblings/reference/stx-ops.scrbl | 48 +++++----- collects/scribblings/reference/syntax.scrbl | 14 ++- collects/sirmail/readr.ss | 17 ++-- collects/sirmail/spell.ss | 3 +- collects/tests/mzscheme/syntax.ss | 22 +++++ doc/release-notes/mzscheme/HISTORY.txt | 5 + src/mzscheme/src/read.c | 41 ++++---- src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/stxobj.c | 99 +++++++++++++++++++- 12 files changed, 232 insertions(+), 58 deletions(-) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 132a23caa6..95965cc3f6 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -224,7 +224,9 @@ profile todo: orig-exp (namespace-syntax-introduce (datum->syntax #f orig-exp)))]) + (printf "> ~s\n" (syntax->datum exp)) (let ([top-e (expand-syntax-to-top-form exp)]) + (printf "~s\n" (syntax->datum top-e)) (syntax-case top-e (begin) [(begin expr ...) ;; Found a `begin', so expand/eval each contained diff --git a/collects/scheme/private/qq-and-or.ss b/collects/scheme/private/qq-and-or.ss index b8772c2ccf..ee0d490d92 100644 --- a/collects/scheme/private/qq-and-or.ss +++ b/collects/scheme/private/qq-and-or.ss @@ -328,7 +328,35 @@ (list (quote-syntax quote) (prefab-struct-key (syntax-e x))) l2)))) - x)))))))) + ;; hash or hasheq + (if (if (syntax? x) + (hash? (syntax-e x)) + #f) + (letrec-values + (((qq-hash-assocs) + (lambda (x level) + (if (null? x) + (quote-syntax ()) + (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 (((l0) (hash-map (syntax-e x) cons))) + (let-values + (((l) (qq-hash-assocs l0 level))) + (if (eq? l0 l) + x + (list (if (hash-eq? (syntax-e x)) + (quote-syntax make-immutable-hasheq) + (if (hash-eqv? (syntax-e x)) + (quote-syntax make-immutable-hasheqv) + (quote-syntax make-immutable-hash))) + l))))) + x))))))))) (qq form 0)) form) in-form))))) diff --git a/collects/scribblings/reference/reader.scrbl b/collects/scribblings/reference/reader.scrbl index bda118e113..9e028cb018 100644 --- a/collects/scribblings/reference/reader.scrbl +++ b/collects/scribblings/reference/reader.scrbl @@ -582,8 +582,9 @@ can be disabled through the @scheme[read-square-bracket-as-paren] and The elements of the structure are recursively read until a matching @litchar{)}, @litchar{]}, or @litchar["}"] is found, just as for lists -(see @secref["parse-pair"]). A delimited @litchar{.} is not allowed -among the elements. +(see @secref["parse-pair"]). A single delimited @litchar{.} is not +allowed among the elements, but two @litchar{.}s can be used as in a +list for an infix conversion. The first element is used as the structure descriptor, and it must have the form (when quoted) of a possible argument to diff --git a/collects/scribblings/reference/stx-ops.scrbl b/collects/scribblings/reference/stx-ops.scrbl index b40ddf2cab..d9a5d48f25 100644 --- a/collects/scribblings/reference/stx-ops.scrbl +++ b/collects/scribblings/reference/stx-ops.scrbl @@ -98,6 +98,9 @@ leaving nested syntax structure (if any) in place. The result of @item{an immutable box containing @tech{syntax object}s} + @item{an immutable @tech{hash table} containing @tech{syntax + object} values (but not necessarily @tech{syntax object} keys)} + @item{an immutable @tech{prefab} structure containing @tech{syntax object}s} @item{some other kind of datum---usually a number, boolean, or string} @@ -128,13 +131,13 @@ are flattened.} Returns a datum by stripping the lexical information, source-location information, properties, and certificates from @scheme[stx]. Inside of -pairs, (immutable) vectors, (immutable) boxes, and immutable -@tech{prefab} structures, @tech{syntax object}s are recursively -stripped. +pairs, (immutable) vectors, (immutable) boxes, immutable @tech{hash +table} values (not keys), and immutable @tech{prefab} structures, +@tech{syntax object}s are recursively stripped. The stripping operation does not mutate @scheme[stx]; it creates new -pairs, vectors, boxes, and @tech{prefab} structures as needed to strip lexical and -source-location information recursively.} +pairs, vectors, boxes, hash tables, and @tech{prefab} structures as +needed to strip lexical and source-location information recursively.} @defproc[(datum->syntax [ctxt (or/c syntax? #f)] [v any/c] @@ -154,23 +157,25 @@ source-location information recursively.} syntax?]{ Converts the @tech{datum} @scheme[v] to a @tech{syntax object}. If -@scheme[v] is a pair, vector, box, or immutable @tech{prefab} -structure, then the contents are recursively converted; mutable -vectors and boxes are essentially replaced by immutable vectors and -boxes. @tech{Syntax object}s already in @scheme[v] are preserved as-is -in the result. For any kind of value other than a pair, vector, box, -immutable @tech{prefab} structure, or @tech{syntax object}, conversion -means wrapping the value with lexical information, source-location +@scheme[v] is a pair, vector, box, immutable hash table, or immutable +@tech{prefab} structure, then the contents are recursively converted; +mutable vectors and boxes are essentially replaced by immutable +vectors and boxes. @tech{Syntax object}s already in @scheme[v] are +preserved as-is in the result. For any kind of value other than a +pair, vector, box, immutable @tech{hash table}, immutable +@tech{prefab} structure, or @tech{syntax object}, conversion means +wrapping the value with lexical information, source-location information, properties, and certificates. Converted objects in @scheme[v] are given the lexical context information of @scheme[ctxt] and the source-location information of -@scheme[srcloc]. If @scheme[v] is not already a @tech{syntax object}, then -the resulting immediate @tech{syntax object} is given the properties (see -@secref["stxprops"]) of @scheme[prop] and the @tech{inactive -certificates} (see @secref["stxcerts"]) of @scheme[cert]; if -@scheme[v] is a pair, vector, box, or immutable @tech{prefab} structure, -recursively converted values are not given properties or certificates. +@scheme[srcloc]. If @scheme[v] is not already a @tech{syntax object}, +then the resulting immediate @tech{syntax object} is given the +properties (see @secref["stxprops"]) of @scheme[prop] and the +@tech{inactive certificates} (see @secref["stxcerts"]) of +@scheme[cert]; if @scheme[v] is a pair, vector, box, immutable +@tech{hash table}, or immutable @tech{prefab} structure, recursively +converted values are not given properties or certificates. Any of @scheme[ctxt], @scheme[srcloc], @scheme[prop], or @scheme[cert] can be @scheme[#f], in which case the resulting syntax has no lexical @@ -194,9 +199,10 @@ numbers or both be @scheme[#f], otherwise the @exnraise[exn:fail:contract]. Graph structure is not preserved by the conversion of @scheme[v] to a -@tech{syntax object}. Instead, @scheme[v] is essentially unfolded into a -tree. If @scheme[v] has a cycle through pairs, vectors, boxes, and immutable -@tech{prefab} structures, then the @exnraise[exn:fail:contract].} +@tech{syntax object}. Instead, @scheme[v] is essentially unfolded into +a tree. If @scheme[v] has a cycle through pairs, vectors, boxes, +immutable @tech{hash tables}, and immutable @tech{prefab} structures, +then the @exnraise[exn:fail:contract].} @defproc[(identifier? [v any/c]) boolean?]{ diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 4e40dcd3ac..a1edd5003d 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -1874,10 +1874,14 @@ quoted vector, or as an element of a quoted @tech{prefab} structure; in the case of a pair, if the @scheme[cdr] of the relevant quoted pair is empty, then @scheme[_expr] need not produce a list, and its result is used directly in place of the quoted pair (in the same way that -@scheme[append] accepts a non-list final argument). If -@scheme[unquote] or @scheme[unquote-splicing] appears within -@scheme[quasiquote] in any other way than as @scheme[(unquote _expr)] -or @scheme[(unquote-splicing _expr)], a syntax error is reported. +@scheme[append] accepts a non-list final argument). In a quoted +@tech{hash table}, an @scheme[(unquote _expr)] or +@scheme[(unquote-splicing _expr)] expression escapes only in the +second element of an entry pair (i.e., the value), while entry keys +are always implicitly quoted. If @scheme[unquote] or +@scheme[unquote-splicing] appears within @scheme[quasiquote] in any +other way than as @scheme[(unquote _expr)] or +@scheme[(unquote-splicing _expr)], a syntax error is reported. @mz-examples[ (eval:alts (#,(scheme quasiquote) (0 1 2)) `(0 1 2)) @@ -1895,6 +1899,8 @@ form is typically abbreviated with @litchar{`}, @litchar{,}, or `(0 1 2) `(1 ,(+ 1 2) 4) `#s(stuff 1 ,(+ 1 2) 4) +(eval:alts #,(schemefont (schemevalfont "`#hash((\"a\" . ") "," (scheme (+ 1 2)) (schemevalfont "))")) #hash(("a" . 3))) +`#hash((,(+ 1 2) . "a")) `(1 ,@(list 1 2) 4) `#(1 ,@(list 1 2) 4) ] diff --git a/collects/sirmail/readr.ss b/collects/sirmail/readr.ss index 0621950186..23ab647ec6 100644 --- a/collects/sirmail/readr.ss +++ b/collects/sirmail/readr.ss @@ -2563,12 +2563,13 @@ (send t change-style url-delta s e))) (when (eq? (system-type) 'macosx) (when fn - (let ([safer-fn (normalize-path (build-path (find-system-path 'desk-dir) - (regexp-replace* #rx"[/\"|:<>\\]" fn "-")))]) - (let ([and-open - (lambda (dir) + (let ([and-open + (lambda (dir) + (let ([safer-fn (normalize-path (build-path (find-system-path 'home-dir) + dir + (regexp-replace* #rx"[/\"|:<>\\]" fn "-")))]) (insert " " set-standard-style) - (insert (format "[~a & open]" dir) + (insert (format "[~~/~a & open]" dir) (lambda (t s e) (send t set-clickback s e (lambda (a b c) @@ -2576,9 +2577,9 @@ (parameterize ([current-input-port (open-input-string "")]) (system* "/usr/bin/open" (path->string safer-fn)))) #f #f) - (send t change-style url-delta s e))))]) - (and-open "~/Desktop") - (and-open "~/Temp")))))) + (send t change-style url-delta s e)))))]) + (and-open "Desktop") + (and-open "Temp"))))) (insert "\n" set-standard-style) (lambda () (unless content diff --git a/collects/sirmail/spell.ss b/collects/sirmail/spell.ss index f1ce0ce133..fc4dd82445 100644 --- a/collects/sirmail/spell.ss +++ b/collects/sirmail/spell.ss @@ -132,7 +132,8 @@ '("/sw/bin" "/usr/bin" "/bin" - "/usr/local/bin"))) + "/usr/local/bin" + "/opt/local/bin"))) '("ispell" "aspell")) (find-executable-path (if (eq? (system-type) 'windows) "aspell.exe" diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index 219256cefe..cb38db8f37 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -651,6 +651,28 @@ (test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote x)))))) 'qq ````,,,x) (test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote 5)))))) 'qq ````,,,,x) +(test '#hash() 'qq `#hash()) +(test '#hash(("apple" . 1) ("banana" . 2) ("coconut" . 3)) + 'qq + `#hash(("apple" . 1) ("banana" . 2) ("coconut" . 3))) +(test '#hash(("apple" . 1) ("banana" . 2) ("coconut" . 3)) + 'qq + `#hash(("apple" . ,1) ("banana" . ,(add1 1)) ("coconut" . ,(+ 1 2)))) +(test '#hash(("foo" . (1 2 3 4 5))) + 'qq + `#hash(("foo" . (1 2 ,(+ 1 2) 4 5)))) +(test '#hash(("foo" . (1 2 3 4 5))) + 'qq + `#hash(("foo" . (1 2 ,@(list 3 4 5))))) +(test '#hash((,(read) . 1) (,(+ 1 2) . 3)) + 'qq + `#hash((,(read) . 1) (,(+ 1 2) . ,(+ 1 2)))) +(test '#hash((,(read) . 2)) + 'qq + `#hash((,(read) . 1) (,(read) . 2))) +(syntax-test #'`#hash(("foo" . ,@(list 1 2 3 4 5)))) +(error-test #'(read (open-input-string "`#hash((foo ,@(list 1 2 3 4 5)))")) exn:fail:read?) + (test '(quasiquote (unquote result)) 'qq `(quasiquote ,result)) (test (list 'quasiquote car) 'qq `(,'quasiquote ,car)) diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 7516e5367d..f45f79c843 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,8 @@ +Version 4.1.4.3 +Allow infix notation for prefab structure literals +Change quasiquote so that unquote works in value positions of #hash +Change read-syntax to represent #hash value forms as syntax + Version 4.1.4.2 Added bitwise-bit-field diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index 6d6e4e5afe..95e11ad68d 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -145,6 +145,7 @@ static MZ_INLINE long SPAN(Scheme_Object *port, long pos) { #define mz_shape_vec 1 #define mz_shape_hash_list 2 #define mz_shape_hash_elem 3 +#define mz_shape_vec_plus_infix 4 typedef struct Readtable { Scheme_Object so; @@ -208,7 +209,7 @@ static Scheme_Object *read_vector(Scheme_Object *port, Scheme_Object *stxsrc, long reqLen, const mzchar *reqBuffer, Scheme_Hash_Table **ht, Scheme_Object *indentation, - ReadParams *params); + ReadParams *params, int allow_infix); static Scheme_Object *read_number(int init_ch, Scheme_Object *port, Scheme_Object *stxsrc, long line, long col, long pos, @@ -1045,7 +1046,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * break; case '(': if (!params->honu_mode) { - return read_vector(port, stxsrc, line, col, pos, ch, ')', -1, NULL, ht, indentation, params); + return read_vector(port, stxsrc, line, col, pos, ch, ')', -1, NULL, ht, indentation, params, 0); } break; case '[': @@ -1054,7 +1055,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#['"); return NULL; } else - return read_vector(port, stxsrc, line, col, pos, ch, ']', -1, NULL, ht, indentation, params); + return read_vector(port, stxsrc, line, col, pos, ch, ']', -1, NULL, ht, indentation, params, 0); } break; case '{': @@ -1063,7 +1064,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#{'"); return NULL; } else - return read_vector(port, stxsrc, line, col, pos, ch, '}', -1, NULL, ht, indentation, params); + return read_vector(port, stxsrc, line, col, pos, ch, '}', -1, NULL, ht, indentation, params, 0); } break; case '\\': @@ -1153,7 +1154,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * else if (effective_ch == '{') ch = '}'; - v = read_vector(port, stxsrc, line, col, pos, orig_ch, ch, -1, NULL, ht, indentation, params); + v = read_vector(port, stxsrc, line, col, pos, orig_ch, ch, -1, NULL, ht, indentation, params, 1); if (stxsrc) v = SCHEME_STX_VAL(v); @@ -1697,11 +1698,11 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * effective_ch = readtable_effective_char(table, ch); if (effective_ch == '(') - return read_vector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params); + return read_vector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, 0); if (effective_ch == '[' && params->square_brackets_are_parens) - return read_vector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params); + return read_vector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, 0); if (effective_ch == '{' && params->curly_braces_are_parens) - return read_vector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params); + return read_vector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, 0); if (ch == '#' && (vector_length != -1)) { /* Not a vector after all: a graph reference */ @@ -2720,7 +2721,10 @@ read_list(Scheme_Object *port, track_indentation(indentation, dotline, dotcol); - if (((shape != mz_shape_cons) && (shape != mz_shape_hash_elem)) || infixed) { + if (((shape != mz_shape_cons) + && (shape != mz_shape_hash_elem) + && (shape != mz_shape_vec_plus_infix)) + || infixed) { scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, 0, indentation, "read: illegal use of `%c'", dot_ch); @@ -2730,7 +2734,7 @@ read_list(Scheme_Object *port, cdr = read_inner(port, stxsrc, ht, indentation, params, RETURN_HONU_ANGLE); ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params); effective_ch = readtable_effective_char(params->table, ch); - if (effective_ch != closer) { + if ((effective_ch != closer) || (shape == mz_shape_vec_plus_infix)) { if (params->can_read_infix_dot && (effective_ch == '.') && next_is_delim(port, params, brackets, braces)) { @@ -3271,14 +3275,16 @@ read_vector (Scheme_Object *port, int opener, char closer, long requestLength, const mzchar *reqBuffer, Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) + Scheme_Object *indentation, ReadParams *params, int allow_infix) /* requestLength == -1 => no request requestLength == -2 => overflow */ { Scheme_Object *lresult, *obj, *vec, **els; int len, i; - lresult = read_list(port, stxsrc, line, col, pos, opener, closer, mz_shape_vec, 1, ht, indentation, params); + lresult = read_list(port, stxsrc, line, col, pos, opener, closer, + allow_infix ? mz_shape_vec_plus_infix : mz_shape_vec, + 1, ht, indentation, params); if (requestLength == -2) { scheme_raise_out_of_memory("read", "making vector of size %5", reqBuffer); @@ -3974,12 +3980,11 @@ static Scheme_Object *read_hash(Scheme_Object *port, Scheme_Object *stxsrc, t = scheme_make_hash_tree(kind); - l = scheme_syntax_to_datum(l, 0, NULL); - - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - val = SCHEME_CAR(l); - key = SCHEME_CAR(val); - val = SCHEME_CDR(val); + for (; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + val = SCHEME_STX_CAR(l); + key = SCHEME_STX_CAR(val); + key = scheme_syntax_to_datum(key, 0, NULL); + val = SCHEME_STX_CDR(val); t = scheme_hash_tree_set(t, key, val); } diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index f71b51c777..baece58a99 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.4.2" +#define MZSCHEME_VERSION "4.1.4.3" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 4 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 3 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 06d2ee79bb..b8a6e75373 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -111,7 +111,7 @@ static void preemptive_chunk(Scheme_Stx *stx); #define CONS scheme_make_pair #define ICONS scheme_make_pair -#define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj)) +#define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj)) XFORM_NONGCING static int prefab_p(Scheme_Object *o) { @@ -2702,6 +2702,22 @@ Scheme_Object *scheme_stx_content(Scheme_Object *o) } v = v2; + } else if (SCHEME_HASHTRP(v)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; + Scheme_Object *key, *val; + int i; + + ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); + + i = scheme_hash_tree_next(ht, -1); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val = propagate_wraps(val, wl_count, &ml, here_wraps); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + + v = (Scheme_Object *)ht2; } else if (prefab_p(v)) { Scheme_Structure *s = (Scheme_Structure *)v; Scheme_Object *r; @@ -2893,6 +2909,42 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) SCHEME_SET_IMMUTABLE(v2); return v2; + } else if (SCHEME_HASHTRP(o)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o, *ht2; + Scheme_Object *key = NULL, *val, *e, *jkey; + int i, j; + + j = scheme_hash_tree_next(ht, -1); + while (j != -1) { + scheme_hash_tree_index(ht, j, &key, &val); + e = stx_activate_certs(val, cp); + if (!SAME_OBJ(e, val)) + break; + j = scheme_hash_tree_next(ht, j); + } + + if (j == -1) + return o; + jkey = key; + + ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); + + i = scheme_hash_tree_next(ht, -1); + while (i != j) { + scheme_hash_tree_index(ht, i, &key, &val); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + ht2 = scheme_hash_tree_set(ht2, key, e); + i = scheme_hash_tree_next(ht, i); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val = stx_activate_certs(val, cp); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + + return (Scheme_Object *)ht2; } else if (prefab_p(o)) { Scheme_Object *e = NULL; Scheme_Structure *s = (Scheme_Structure *)o; @@ -5831,6 +5883,22 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, result = r; SCHEME_SET_IMMUTABLE(result); + } else if (SCHEME_HASHTRP(v)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; + Scheme_Object *key, *val; + int i; + + ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); + + i = scheme_hash_tree_next(ht, -1); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val = syntax_to_datum_inner(val, with_marks, mt); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + + result = (Scheme_Object *)ht2; } else if (prefab_p(v)) { Scheme_Structure *s = (Scheme_Structure *)v; Scheme_Object *a; @@ -6624,6 +6692,23 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, } SCHEME_SET_VECTOR_IMMUTABLE(result); + } else if (SCHEME_HASHTRP(o)) { + Scheme_Hash_Tree *ht1 = (Scheme_Hash_Tree *)o, *ht2; + Scheme_Object *key, *val; + int i; + + ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht1) & 0x3); + + i = scheme_hash_tree_next(ht1, -1); + while (i != -1) { + scheme_hash_tree_index(ht1, i, &key, &val); + val = datum_to_syntax_inner(val, ut, stx_src, stx_wraps, ht); + if (!val) return NULL; + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht1, i); + } + + result = (Scheme_Object *)ht2; } else if (prefab_p(o)) { Scheme_Structure *s = (Scheme_Structure *)o; Scheme_Object *a; @@ -6632,6 +6717,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); for (i = 0; i < size; i++) { a = datum_to_syntax_inner(s->slots[i], ut, stx_src, stx_wraps, ht); + if (!a) return NULL; s->slots[i] = a; } @@ -6854,6 +6940,17 @@ static void simplify_syntax_inner(Scheme_Object *o, for (i = 0; i < size; i++) { simplify_syntax_inner(SCHEME_VEC_ELS(v)[i], rns, marks); } + } else if (SCHEME_HASHTRP(v)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v; + Scheme_Object *key, *val; + int i; + + i = scheme_hash_tree_next(ht, -1); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + simplify_syntax_inner(val, rns, marks); + i = scheme_hash_tree_next(ht, i); + } } else if (prefab_p(v)) { Scheme_Structure *s = (Scheme_Structure *)v; int size = s->stype->num_slots, i;