diff options
Diffstat (limited to 'mwdenote.scm')
| -rw-r--r-- | mwdenote.scm | 273 |
1 files changed, 273 insertions, 0 deletions
diff --git a/mwdenote.scm b/mwdenote.scm new file mode 100644 index 0000000..c3fe5f3 --- /dev/null +++ b/mwdenote.scm @@ -0,0 +1,273 @@ +;"mwdenote.scm" Syntactic Environments +; Copyright 1992 William Clinger +; +; Permission to copy this software, in whole or in part, to use this +; software for any lawful purpose, and to redistribute this software +; is granted subject to the restriction that all copies made of this +; software must include this copyright notice in full. +; +; I also request that you send me a copy of any improvements that you +; make to this software so that they may be incorporated within it to +; the benefit of the Scheme community. + +;;;; Syntactic environments. + +; A syntactic environment maps identifiers to denotations, +; where a denotation is one of +; +; (special <special>) +; (macro <rules> <env>) +; (identifier <id>) +; +; and where <special> is one of +; +; quote +; lambda +; if +; set! +; begin +; define +; define-syntax +; let-syntax +; letrec-syntax +; syntax-rules +; +; and where <rules> is a compiled <transformer spec> (see R4RS), +; <env> is a syntactic environment, and <id> is an identifier. + +(define mw:standard-syntax-environment + '((quote . (special quote)) + (lambda . (special lambda)) + (if . (special if)) + (set! . (special set!)) + (begin . (special begin)) + (define . (special define)) + (let . (special let)) ;; @@ added KAD + (let* . (special let*)) ;; @@ " + (letrec . (special letrec)) ;; @@ " + (quasiquote . (special quasiquote)) ;; @@ " + (unquote . (special unquote)) ;; @@ " + (unquote-splicing . (special unquote-splicing)) ; @@ " + (do . (special do)) ;; @@ " + (define-syntax . (special define-syntax)) + (let-syntax . (special let-syntax)) + (letrec-syntax . (special letrec-syntax)) + (syntax-rules . (special syntax-rules)) + (... . (identifier ...)) + (::: . (identifier :::)))) + +; An unforgeable synonym for lambda, used to expand definitions. + +(define mw:lambda0 (string->symbol " lambda ")) + +; The mw:global-syntax-environment will always be a nonempty +; association list since there is no way to remove the entry +; for mw:lambda0. That entry is used as a header by destructive +; operations. + +(define mw:global-syntax-environment + (cons (cons mw:lambda0 + (cdr (assq 'lambda mw:standard-syntax-environment))) + (mw:syntax-copy mw:standard-syntax-environment))) + +(define (mw:global-syntax-environment-set! env) + (set-cdr! mw:global-syntax-environment env)) + +(define (mw:syntax-bind-globally! id denotation) + (if (and (mw:identifier? denotation) + (eq? id (mw:identifier-name denotation))) + (letrec ((remove-bindings-for-id + (lambda (bindings) + (cond ((null? bindings) '()) + ((eq? (caar bindings) id) + (remove-bindings-for-id (cdr bindings))) + (else (cons (car bindings) + (remove-bindings-for-id (cdr bindings)))))))) + (mw:global-syntax-environment-set! + (remove-bindings-for-id (cdr mw:global-syntax-environment)))) + (let ((x (assq id mw:global-syntax-environment))) + (if x + (set-cdr! x denotation) + (mw:global-syntax-environment-set! + (cons (cons id denotation) + (cdr mw:global-syntax-environment))))))) + +(define (mw:syntax-divert env1 env2) + (append env2 env1)) + +(define (mw:syntax-extend env ids denotations) + (mw:syntax-divert env (map cons ids denotations))) + +(define (mw:syntax-lookup-raw env id) + (let ((entry (assq id env))) + (if entry + (cdr entry) + #f))) + +(define (mw:syntax-lookup env id) + (or (mw:syntax-lookup-raw env id) + (mw:make-identifier-denotation id))) + +(define (mw:syntax-assign! env id denotation) + (let ((entry (assq id env))) + (if entry + (set-cdr! entry denotation) + (mw:bug "Bug detected in mw:syntax-assign!" env id denotation)))) + +(define mw:denote-of-quote + (mw:syntax-lookup mw:standard-syntax-environment 'quote)) + +(define mw:denote-of-lambda + (mw:syntax-lookup mw:standard-syntax-environment 'lambda)) + +(define mw:denote-of-if + (mw:syntax-lookup mw:standard-syntax-environment 'if)) + +(define mw:denote-of-set! + (mw:syntax-lookup mw:standard-syntax-environment 'set!)) + +(define mw:denote-of-begin + (mw:syntax-lookup mw:standard-syntax-environment 'begin)) + +(define mw:denote-of-define + (mw:syntax-lookup mw:standard-syntax-environment 'define)) + +(define mw:denote-of-define-syntax + (mw:syntax-lookup mw:standard-syntax-environment 'define-syntax)) + +(define mw:denote-of-let-syntax + (mw:syntax-lookup mw:standard-syntax-environment 'let-syntax)) + +(define mw:denote-of-letrec-syntax + (mw:syntax-lookup mw:standard-syntax-environment 'letrec-syntax)) + +(define mw:denote-of-syntax-rules + (mw:syntax-lookup mw:standard-syntax-environment 'syntax-rules)) + +(define mw:denote-of-... + (mw:syntax-lookup mw:standard-syntax-environment '...)) + +(define mw:denote-of-::: + (mw:syntax-lookup mw:standard-syntax-environment ':::)) + +(define mw:denote-of-let + (mw:syntax-lookup mw:standard-syntax-environment 'let)) ;; @@ KenD + +(define mw:denote-of-let* + (mw:syntax-lookup mw:standard-syntax-environment 'let*)) ;; @@ KenD + +(define mw:denote-of-letrec + (mw:syntax-lookup mw:standard-syntax-environment 'letrec)) ;; @@ KenD + +(define mw:denote-of-quasiquote + (mw:syntax-lookup mw:standard-syntax-environment 'quasiquote)) ;; @@ KenD + +(define mw:denote-of-unquote + (mw:syntax-lookup mw:standard-syntax-environment 'unquote)) ;; @@ KenD + +(define mw:denote-of-unquote-splicing + (mw:syntax-lookup mw:standard-syntax-environment 'unquote-splicing)) ;@@ KenD + +(define mw:denote-of-do + (mw:syntax-lookup mw:standard-syntax-environment 'do)) ;; @@ KenD + +(define mw:denote-class car) + +;(define (mw:special? denotation) +; (eq? (mw:denote-class denotation) 'special)) + +;(define (mw:macro? denotation) +; (eq? (mw:denote-class denotation) 'macro)) + +(define (mw:identifier? denotation) + (eq? (mw:denote-class denotation) 'identifier)) + +(define (mw:make-identifier-denotation id) + (list 'identifier id)) + +(define macwork:rules cadr) +(define macwork:env caddr) +(define mw:identifier-name cadr) + +(define (mw:same-denotation? d1 d2) + (or (eq? d1 d2) + (and (mw:identifier? d1) + (mw:identifier? d2) + (eq? (mw:identifier-name d1) + (mw:identifier-name d2))))) + +; Renaming of variables. + +; Given a datum, strips the suffixes from any symbols that appear within +; the datum, trying not to copy any more of the datum than necessary. +; Well, right now I'm just copying the datum, but I need to fix that! + +(define (mw:strip x) + (cond ((symbol? x) + (let ((chars (memv mw:suffix-character + (reverse (string->list + (symbol->string x)))))) + (if chars + (string->symbol + (list->string (reverse (cdr chars)))) + x))) + ((pair? x) + (cons (mw:strip (car x)) + (mw:strip (cdr x)))) + ((vector? x) + (list->vector (map mw:strip (vector->list x)))) + (else x))) + +; Given a list of identifiers, returns an alist that associates each +; identifier with a fresh identifier. + +(define (mw:rename-vars vars) + (set! mw:renaming-counter (+ mw:renaming-counter 1)) + (let ((suffix (string-append (string mw:suffix-character) + (number->string mw:renaming-counter)))) + (map (lambda (var) + (if (symbol? var) + (cons var + (string->symbol + (string-append (symbol->string var) suffix))) + (slib:error "Illegal variable" var))) + vars))) + +; Given a syntactic environment env to be extended, an alist returned +; by mw:rename-vars, and a syntactic environment env2, extends env by +; binding the fresh identifiers to the denotations of the original +; identifiers in env2. + +(define (mw:syntax-alias env alist env2) + (mw:syntax-divert + env + (map (lambda (name-pair) + (let ((old-name (car name-pair)) + (new-name (cdr name-pair))) + (cons new-name + (mw:syntax-lookup env2 old-name)))) + alist))) + +; Given a syntactic environment and an alist returned by mw:rename-vars, +; extends the environment by binding the old identifiers to the fresh +; identifiers. + +(define (mw:syntax-rename env alist) + (mw:syntax-divert env + (map (lambda (old new) + (cons old (mw:make-identifier-denotation new))) + (map car alist) + (map cdr alist)))) + +; Given a <formals> and an alist returned by mw:rename-vars that contains +; a new name for each formal identifier in <formals>, renames the +; formal identifiers. + +(define (mw:rename-formals formals alist) + (cond ((null? formals) '()) + ((pair? formals) + (cons (cdr (assq (car formals) alist)) + (mw:rename-formals (cdr formals) alist))) + (else (cdr (assq formals alist))))) + +(define mw:renaming-counter 0) |