From 017856b79d2dd2a046b211b3850fb90237065a15 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 12 Feb 2018 22:03:09 -0800 Subject: [PATCH] Make sure history is correct for identifiers in declarations. Plumb selectors through map-decl-ids and pass to procedure. --- src/runtime/mit-syntax.scm | 5 +- src/runtime/runtime.pkg | 3 + src/runtime/syntax-declaration.scm | 136 +++++++++++++++++------------ src/runtime/syntax-rename.scm | 10 ++- src/runtime/syntax.scm | 29 +++--- 5 files changed, 110 insertions(+), 73 deletions(-) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index 14757f77d..7444436ab 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -305,9 +305,8 @@ USA. (subform-hists decls hist))) (define (classify-decl decl senv hist) - (map-decl-ids (lambda (id) - ;; Need to get the right hist here. - (classify-id id senv hist)) + (map-decl-ids (lambda (id selector) + (classify-id id senv (hist-select selector hist))) decl)) (define (classify-id id senv hist) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 281df7bac..dfc58f02f 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4403,8 +4403,11 @@ USA. syntax* syntax-error) (export (runtime syntax) + biselect-cadr biselect-car + biselect-cddr biselect-cdr + biselect-list-elts biselect-subform biselector:cadddr biselector:caddr diff --git a/src/runtime/syntax-declaration.scm b/src/runtime/syntax-declaration.scm index 42ea88d76..ede42ac19 100644 --- a/src/runtime/syntax-declaration.scm +++ b/src/runtime/syntax-declaration.scm @@ -51,94 +51,114 @@ USA. (cdr declaration)))) (entry (assq (car declaration) known-declarations))) (if (and entry (syntax-match? (cadr entry) (cdr declaration))) - ((cddr entry) declaration procedure) + ((cddr entry) procedure declaration biselector:cr) (begin (warn "Unknown declaration:" declaration) declaration)))) +(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 (declaration procedure) + (lambda (procedure declaration selector) (cons (car declaration) - (map procedure (cdr declaration)))))) + (map+ procedure + (cdr declaration) + (biselect-cdr selector)))))) ;; The names in USUAL-INTEGRATIONS are always global. '( - USUAL-INTEGRATIONS - IGNORABLE - IGNORE - INTEGRATE - INTEGRATE-OPERATOR - INTEGRATE-SAFELY - TYPE-CHECKS - NO-TYPE-CHECKS - RANGE-CHECKS - NO-RANGE-CHECKS + usual-integrations + ignorable + ignore + integrate + integrate-operator + integrate-safely + type-checks + no-type-checks + range-checks + no-range-checks )) -(define-declaration 'INTEGRATE-EXTERNAL +(define-declaration 'integrate-external `(* ,(lambda (object) (or (string? object) (pathname? object)))) - (lambda (declaration procedure) - procedure + (lambda (procedure declaration selector) + (declare (ignore procedure selector)) declaration)) (for-each (lambda (keyword) - (define-declaration keyword '(DATUM) - (lambda (declaration procedure) + (define-declaration keyword '(datum) + (lambda (procedure declaration selector) (list (car declaration) - (let loop ((varset (cadr declaration))) + (let loop + ((varset (cadr declaration)) + (selector (biselect-cadr selector))) (cond ((syntax-match? '('set * identifier) varset) (cons (car varset) - (map procedure (cdr varset)))) + (map+ procedure + (cdr varset) + (biselect-cdr selector)))) ((syntax-match?* '(('union * datum) ('intersection * datum) ('difference datum datum)) varset) (cons (car varset) - (map loop (cdr varset)))) + (map+ loop + (cdr varset) + (biselect-cdr selector)))) (else varset))))))) - '(CONSTANT - IGNORE-ASSIGNMENT-TRAPS - IGNORE-REFERENCE-TRAPS - PURE-FUNCTION - SIDE-EFFECT-FREE - USUAL-DEFINITION - UUO-LINK)) + '(constant + ignore-assignment-traps + ignore-reference-traps + pure-function + side-effect-free + usual-definition + uuo-link)) -(define-declaration 'REPLACE-OPERATOR '(* (IDENTIFIER * (DATUM DATUM))) - (lambda (declaration procedure) +(define-declaration 'replace-operator '(* (identifier * (datum datum))) + (lambda (procedure declaration selector) (cons (car declaration) - (map (lambda (rule) - (cons (procedure (car rule)) - (map (lambda (clause) - (list (car clause) - (if (identifier? (cadr clause)) - (procedure (cadr clause)) - (cadr clause)))) - (cdr rule)))) - (cdr declaration))))) + (map+ (lambda (rule selector) + (cons (procedure (car rule) (biselect-car selector)) + (map+ (lambda (clause selector) + (list (car clause) + (if (identifier? (cadr clause)) + (procedure + (cadr clause) + (biselect-cadr selector)) + (cadr clause)))) + (cdr rule) + (biselect-cdr selector)))) + (cdr declaration) + (biselect-cdr selector))))) -(define-declaration 'REDUCE-OPERATOR '(* (IDENTIFIER DATUM * DATUM)) - (lambda (declaration procedure) +(define-declaration 'reduce-operator '(* (identifier datum * datum)) + (lambda (procedure declaration selector) (cons (car declaration) - (map (lambda (rule) - (cons* (procedure (car rule)) - (if (identifier? (cadr rule)) - (procedure (cadr rule)) - (cadr rule)) - (map (lambda (clause) - (if (syntax-match?* - '(('null-value identifier datum) - ('singleton identifier) - ('wrapper identifier ? datum)) - clause) - (cons* (car clause) - (procedure (cadr clause)) - (cddr clause)) - clause)) - (cddr rule)))) - (cdr declaration))))) \ No newline at end of file + (map+ (lambda (rule selector) + (cons* (procedure (car rule) (biselect-car selector)) + (if (identifier? (cadr rule)) + (procedure (cadr rule) (biselect-cadr selector)) + (cadr rule)) + (map+ (lambda (clause selector) + (if (syntax-match?* + '(('null-value identifier datum) + ('singleton identifier) + ('wrapper identifier ? datum)) + clause) + (cons* (car clause) + (procedure (cadr clause) + (biselect-cadr selector)) + (cddr clause)) + clause)) + (cddr rule) + (biselect-cddr selector)))) + (cdr declaration) + (biselect-cdr selector))))) \ No newline at end of file diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm index f4f8d26b3..8029925b7 100644 --- a/src/runtime/syntax-rename.scm +++ b/src/runtime/syntax-rename.scm @@ -339,7 +339,10 @@ USA. (make-scode-open-block (map substitution (scode-open-block-names expression)) (map (lambda (declaration) - (map-decl-ids substitution declaration)) + (map-decl-ids (lambda (id selector) + (declare (ignore selector)) + (substitution id)) + declaration)) (scode-open-block-declarations expression)) (alpha-substitute substitution (scode-open-block-actions expression))))) @@ -347,7 +350,10 @@ USA. (lambda (substitution expression) (make-scode-declaration (map (lambda (declaration) - (map-decl-ids substitution declaration)) + (map-decl-ids (lambda (id selector) + (declare (ignore selector)) + (substitution id)) + declaration)) (scode-declaration-text expression)) (alpha-substitute substitution (scode-declaration-expression expression))))) diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index ddbcc57d2..856da4569 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -262,19 +262,16 @@ USA. ;;;; Binary selectors (define (biselect-car selector) - (let ((n (integer-length selector))) - (+ (shift-left 1 n) - (- selector (shift-left 1 (- n 1)))))) + (biselect-append biselector:car selector)) (define (biselect-cdr selector) - (+ (shift-left 1 (integer-length selector)) - selector)) + (biselect-append biselector:cdr selector)) -(define (biselect-subform selector form) - (if (> selector 1) - (biselect-subform (quotient selector 2) - (if (even? selector) (car form) (cdr form))) - form)) +(define (biselect-cadr selector) + (biselect-append biselector:cadr selector)) + +(define (biselect-cddr selector) + (biselect-append biselector:cddr selector)) ;; Selector order is: ;; (= biselector:cadr (biselect-append biselector:car biselector:cdr)) @@ -286,6 +283,18 @@ USA. biselector:cr selectors)) +(define (biselect-list-elts list selector) + (if (pair? list) + (cons (biselect-car selector) + (biselect-list-elts (cdr list) (biselect-cdr selector))) + '())) + +(define (biselect-subform selector form) + (if (> selector 1) + (biselect-subform (quotient selector 2) + (if (even? selector) (car form) (cdr form))) + form)) + (define-integrable biselector:cr #b00001) (define-integrable biselector:car #b00010) (define-integrable biselector:cdr #b00011) -- 2.25.1