suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix certificates with syntax/loc

Browse Source 
svn: r1203
This commit is contained in:
Matthew Flatt 2005-11-01 22:16:10 +00:00
parent f5addba2df
commit 724296a2c7
5 changed files with 2745 additions and 2735 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5449
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

2
src/mzscheme/src/env.c
View File

@ -100,6 +100,8 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj);
static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data);
int scheme_is_module_begin_env(Scheme_Comp_Env *env);
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif

13
src/mzscheme/src/startup.inc
View File

@ -1680,15 +1680,18 @@
"(syntax-case** #f #t stx() module-identifier=?"
"((_ stxe kl clause ...)"
"(syntax(syntax-case** _ #f stxe kl module-identifier=? clause ...))))))"
"(-define loc-insp(current-code-inspector))"
"(-define(relocate loc stx)"
"(let((new-stx(datum->syntax-object"
" stx"
"(syntax-e stx)"
" loc)))"
"(syntax-recertify new-stx stx loc-insp #f)))"
"(-define-syntax syntax/loc"
"(lambda(stx)"
"(syntax-case** #f #t stx() module-identifier=?"
"((_ loc pattern)"
"(syntax(let((stx(syntax pattern)))"
"(datum->syntax-object"
" stx"
"(syntax-e stx)"
" loc)))))))"
"(syntax(relocate loc(syntax pattern)))))))"
"(provide syntax/loc syntax-case* syntax-case))"
);
EVAL_ONE_STR(

14
src/mzscheme/src/startup.ss
View File

@ -1984,6 +1984,14 @@
[(_ stxe kl clause ...)
(syntax (syntax-case** _ #f stxe kl module-identifier=? clause ...))])))
(-define loc-insp (current-code-inspector))
(-define (relocate loc stx)
(let ([new-stx (datum->syntax-object
stx
(syntax-e stx)
loc)])
(syntax-recertify new-stx stx loc-insp #f)))
;; Like syntax, but also takes a syntax object
;; that supplies a source location for the
;; resulting syntax object.
@ -1991,11 +1999,7 @@
(lambda (stx)
(syntax-case** #f #t stx () module-identifier=?
[(_ loc pattern)
(syntax (let ([stx (syntax pattern)])
(datum->syntax-object
stx
(syntax-e stx)
loc)))])))
(syntax (relocate loc (syntax pattern)))])))
(provide syntax/loc syntax-case* syntax-case))

2
src/mzscheme/src/syntax.c
View File

@ -3019,6 +3019,8 @@ quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_In
if (len != 2)
bad_form(form, len);
scheme_rec_add_certs(rec, drec, form);
stx = SCHEME_STX_CDR(form);
stx = SCHEME_STX_CAR(stx);