From: Chris Hanson Date: Thu, 6 Dec 2018 07:40:36 +0000 (-0800) Subject: Syntax renaming now handles declarations correctly. X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~26 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ed1a18bae121eec1b26a5fcfbf0c54af5294b4ac;p=mit-scheme.git Syntax renaming now handles declarations correctly. --- diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 76c0b85a0..909df86bc 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4812,6 +4812,7 @@ USA. (files "syntax-declaration") (parent (runtime syntax)) (export (runtime syntax) + fold-decl-ids map-decl-ids)) (define-package (runtime syntax mit) diff --git a/src/runtime/syntax-declaration.scm b/src/runtime/syntax-declaration.scm index 84335d6f6..a87190dcc 100644 --- a/src/runtime/syntax-declaration.scm +++ b/src/runtime/syntax-declaration.scm @@ -29,47 +29,58 @@ USA. (declare (usual-integrations)) -(define (define-declaration name pattern mapper) - (let ((entry (assq name known-declarations))) +(define (define-declaration name pattern mapper folder) + (let ((entry (assq name known-declarations)) + (value (list pattern mapper folder))) (if entry - (set-cdr! entry (cons pattern mapper)) + (set-cdr! entry value) (begin (set! known-declarations - (cons (cons name (cons pattern mapper)) + (cons (cons name value) known-declarations)) unspecific)))) (define (map-decl-ids procedure declaration) + (operate-on-decl-ids (lambda (handlers declaration) + ((car handlers) procedure declaration biselector:cr)) + declaration)) + +(define (fold-decl-ids procedure initial declaration) + (operate-on-decl-ids (lambda (handlers declaration) + ((cadr handlers) procedure initial declaration)) + declaration)) + +(define (operate-on-decl-ids procedure declaration) (if (not (pair? declaration)) (error "Ill-formed declaration:" declaration)) (let* ((declaration ;++ This is a kludge -- rather than strip syntactic closures, ;++ it should be aware of the environment. - (if (symbol? (car declaration)) - declaration - (cons (strip-syntactic-closures (car declaration)) - (cdr declaration)))) + (cons (identifier->symbol (car declaration)) + (cdr declaration))) (entry (assq (car declaration) known-declarations))) (if (and entry (syntax-match? (cadr entry) (cdr declaration))) - ((cddr entry) procedure declaration biselector:cr) + (procedure (cddr entry) declaration) (begin (warn "Unknown declaration:" declaration) declaration)))) +(define known-declarations '()) + (define (map+ procedure items selector) (map procedure items (biselect-list-elts items selector))) -(define known-declarations '()) - (for-each (lambda (keyword) (define-declaration keyword '(* identifier) (lambda (procedure declaration selector) (cons (car declaration) (map+ procedure (cdr declaration) - (biselect-cdr selector)))))) + (biselect-cdr selector)))) + (lambda (procedure initial declaration) + (fold procedure initial (cdr declaration))))) ;; The names in USUAL-INTEGRATIONS are always global. '( usual-integrations @@ -90,13 +101,19 @@ USA. (pathname? object)))) (lambda (procedure declaration selector) (declare (ignore procedure selector)) - declaration)) + declaration) + (lambda (procedure initial declaration) + (declare (ignore procedure declaration)) + initial)) (define-declaration 'target-metadata - `(* (symbol * datum)) + '(* (symbol * datum)) (lambda (procedure declaration selector) (declare (ignore procedure selector)) - declaration)) + declaration) + (lambda (procedure initial declaration) + (declare (ignore procedure declaration)) + initial)) (for-each (lambda (keyword) @@ -119,7 +136,17 @@ USA. (map+ loop (cdr varset) (biselect-cdr selector)))) - (else varset))))))) + (else varset))))) + (lambda (procedure initial declaration) + (let loop ((varset (cadr declaration)) (value initial)) + (cond ((syntax-match? '('set * identifier) varset) + (fold procedure value (cdr varset))) + ((syntax-match?* '(('union * datum) + ('intersection * datum) + ('difference datum datum)) + varset) + (fold loop value (cdr varset))) + (else value)))))) '(constant ignore-assignment-traps ignore-reference-traps @@ -143,7 +170,17 @@ USA. (cdr rule) (biselect-cdr selector)))) (cdr declaration) - (biselect-cdr selector))))) + (biselect-cdr selector)))) + (lambda (procedure initial declaration) + (fold (lambda (rule value) + (fold (lambda (clause value*) + (if (identifier? (cadr clause)) + (procedure (cadr clause) value*) + value*)) + (procedure (car rule) value) + (cdr rule))) + initial + (cdr declaration)))) (define-declaration 'reduce-operator '(* (identifier datum * datum)) (lambda (procedure declaration selector) @@ -167,4 +204,20 @@ USA. (cddr rule) (biselect-cddr selector)))) (cdr declaration) - (biselect-cdr selector))))) \ No newline at end of file + (biselect-cdr selector)))) + (lambda (procedure initial declaration) + (fold (lambda (rule value) + (fold (lambda (clause value*) + (if (syntax-match?* '(('null-value identifier datum) + ('singleton identifier) + ('wrapper identifier ? datum)) + clause) + (procedure (cadr clause) value*) + value*)) + (let ((value* (procedure (car rule) value))) + (if (identifier? (cadr rule)) + (procedure (cadr rule) value*) + value*)) + (cddr rule))) + initial + (cdr declaration)))) \ No newline at end of file diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm index 752b806e5..cf0138263 100644 --- a/src/runtime/syntax-rename.scm +++ b/src/runtime/syntax-rename.scm @@ -222,9 +222,22 @@ USA. (define-cs-handler scode-open-block? (lambda (expression mark-safe!) (mark-local-bindings (scode-open-block-names expression) - (scode-open-block-actions expression) + (make-scode-declaration + (scode-open-block-declarations expression) + (scode-open-block-actions expression)) mark-safe!))) + (define-cs-handler scode-declaration? + (lambda (expression mark-safe!) + (fold (lambda (declaration ids) + (fold-decl-ids (lambda (id ids) + (lset-adjoin eq? ids id)) + ids + declaration)) + (compute-substitution (scode-declaration-expression expression) + mark-safe!) + (scode-declaration-text expression)))) + (define-cs-handler quoted-identifier? (simple-subexpression quoted-identifier-identifier))