diff options
Diffstat (limited to 'Macroexpand.scm')
| -rw-r--r-- | Macroexpand.scm | 370 |
1 files changed, 370 insertions, 0 deletions
diff --git a/Macroexpand.scm b/Macroexpand.scm new file mode 100644 index 0000000..3b658f8 --- /dev/null +++ b/Macroexpand.scm @@ -0,0 +1,370 @@ +;; Copyright (C) 1999 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;;; "Macroexpand.scm", macro expansion, respecting hygiene. +;;; Author: Radey Shouman + +;; It is possible to break MACRO:EXPAND by redefining primitive +;; syntax, eg LAMBDA, LET, QUOTE to different primitive syntax, +;; or by defining any of @LAMBDA, @LET, @LET*, @LETREC, @DO, +;; or @EXPAND as primitive syntax. + +;; We still need LET-SYNTAX and LETREC-SYNTAX. + +(define macro:expand + (let (($lambda (renamed-identifier 'lambda '())) + ($let (renamed-identifier 'let '())) + ($let* (renamed-identifier 'let* '())) + ($letrec (renamed-identifier 'letrec '())) + ($do (renamed-identifier 'do '())) + ($define (renamed-identifier 'define '())) + ($quote (renamed-identifier 'quote '())) + ($quasiquote (renamed-identifier 'quasiquote '())) + ($unquote (renamed-identifier 'unquote '())) + ($unquote-splicing (renamed-identifier 'unquote-splicing '())) + ($case (renamed-identifier 'case '())) + ($cond (renamed-identifier 'cond '())) + ($begin (renamed-identifier 'begin '())) + ($if (renamed-identifier 'if '())) + ($and (renamed-identifier 'and '())) + ($or (renamed-identifier 'or '())) + ($set! (renamed-identifier 'set! '())) + ($delay (renamed-identifier 'delay '())) + ($syntax-quote (renamed-identifier 'syntax-quote '())) + ($@apply (renamed-identifier '@apply '())) + ($else (renamed-identifier 'else '())) + (@lambda (renamed-identifier '@lambda '())) + (@let (renamed-identifier '@let '())) + (@let* (renamed-identifier '@let* '())) + (@letrec (renamed-identifier '@letrec '())) + (@do (renamed-identifier '@do '())) + (@expand (renamed-identifier '@expand '()))) + + (define expander + (macro:compile-syntax-rules + '(syntax-rules (lambda let letrec let* do @let*) + ((_ (lambda ?formals ?body ...)) + (@lambda ?formals ?body ...)) + + ((_ (let ((?name ?val) ...) ?body ...)) + (@let ((?name ...) ?val ...) ?body ...)) + ((_ (let ?proc ((?name ?val) ...) ?body ...)) + (@expand + (letrec ((?proc (lambda (?name ...) ?body ...))) + (?proc ?val ...)))) + + ((_ (letrec ((?name ?val) ...) ?body ...)) + (@letrec ((?name ...) ?val ...) ?body ...)) + + ((_ (let* () ?body ...)) + (@let (()) ?body ...)) + ((_ (let* ((?name1 ?val1) (?name ?val) ...) ?body ...)) + (@expand + (@let* (?name1 ?val1) (let* ((?name ?val) ...) ?body ...)))) + ((_ (@let* (?name ?val ...) (let* () ?body ...))) + (@let* (?name ?val ...) ?body ...)) + ((_ (@let* (?name ?val ...) + (let* ((?name2 ?val2) (?name3 ?val3) ...) ?body ...))) + (@expand + (@let* (?name ?val ... ?name2 ?val2) + (let* ((?name3 ?val3) ...) ?body ...)))) + ((_ (@let* (?name ?val ...) ?body ...)) + (@let* (?name ?val ...) ?body ...)) + + ((_ (do ((?var ?init ?step) ...) + (?test ?clause ...) + ?body ...)) + (@do (?var ...) (?init ...) + (?test ?clause ...) + (?body ...) + (?step ...))) + + ((_ ?form) + ?form)) + '())) + + (define (simplify-identifiers expr env) + (let simplify ((expr expr)) + (cond ((identifier? expr) + (let ((sym (identifier->symbol expr))) + (if (identifier-equal? sym expr env) sym expr))) + ((pair? expr) + (cons (simplify (car expr)) + (simplify (cdr expr)))) + (else expr)))) + + (define (unpaint expr) + (cond ((identifier? expr) + (identifier->symbol expr)) + ((pair? expr) + (cons (unpaint (car expr)) (unpaint (cdr expr)))) + ((vector? expr) + (list->vector (map unpaint (vector->list expr)))) + (else expr))) + + (define (defines->bindings defs) + (reverse ;purely cosmetic + (map (lambda (b) + (if (pair? (cadr b)) + (list (caadr b) + (cons $lambda (cons (cdadr b) (cddr b)))) + (cdr b))) + defs))) + + (define (expand-define expr env) + (let ((binding (car (defines->bindings (list expr))))) + (cons (simplify-identifiers $define env) + (list (simplify-identifiers (car binding) env) + (macro:expand (cadr binding) env))))) + + (define (expand-body expr-list env) + (let loop ((defines '()) + (exprs expr-list)) + (if (null? exprs) #f ; should check higher up. + (let ((exp1 (macro:expand (car exprs) env))) + (if (and (pair? exp1) + (identifier? (car exp1)) + (identifier-equal? (car exp1) $define env)) + (loop (cons exp1 defines) (cdr exprs)) + (if (null? defines) + (cons exp1 (expand* (cdr exprs) env)) + (let ((bindings (defines->bindings defines))) + (list + (macro:expand + (cons $letrec (cons bindings exprs)) + env))))))))) + + (define (expand* exprs env) + (map (lambda (x) + (macro:expand x env)) + exprs)) + + ;;(@lambda formals body ...) + (define (expand-lambda expr env) + (let* ((formals (cadr expr)) + (body (cddr expr)) + (bound + (let recur ((f formals)) + (cond ((null? f) '()) + ((pair? f) (cons 'required (recur (cdr f)))) + ((identifier? f) (list 'rest-list)) + (else (error 'lambda 'bad-formals expr))))) + (env1 (extended-environment formals bound env))) + (cons (simplify-identifiers $lambda env) + (cons (simplify-identifiers formals env1) + (expand-body body env1))))) + + ;;(@let ((formals) bindings) body ...) + (define (expand-let expr env) + (let* ((formals (caadr expr)) + (bindings (expand* (cdadr expr) env)) + (env1 (extended-environment formals + (map (lambda (x) 'let) formals) + env))) + (cons (simplify-identifiers $let env) + (cons (map list formals bindings) + (expand-body (cddr expr) env1))))) + + (define (expand-let* expr env) + (let loop ((inp (cadr expr)) + (formals '()) + (bindings '()) + (env1 env)) + (if (null? inp) + (cons (simplify-identifiers $let* env) + (map list (reverse formals) (reverse bindings)) + (expand-body (cddr expr) env1)) + (loop (cddr inp) + (cons (car inp) formals) + (cons (macro:expand (cadr inp) env1) bindings) + (extended-environment (car inp) 'let* env1))))) + + ;;(@letrec ((formals) bindings) body ...) + (define (expand-letrec expr env) + (let* ((formals (caadr expr)) + (env1 (extended-environment + formals + (map (lambda (x) 'letrec) formals) + env)) + (bindings (expand* (cdadr expr) env1))) + (cons (simplify-identifiers $letrec env) + (cons (map list formals bindings) + (expand-body (cddr expr) env1))))) + + ;;(@do vars inits (test clause ...) (body ...) steps) + (define (expand-do expr env) + (let* ((vars (cadr expr)) + (inits (expand* (caddr expr) env)) + (env1 (extended-environment + vars (map (lambda (x) 'do) inits) env)) + (steps (expand* (list-ref expr 5) env1))) + (cons (simplify-identifiers $do env) + (cons + (map list vars inits steps) + (cons (expand* (cadddr expr) env1) + (expand* (list-ref expr 4) env1)))))) + + (define (expand-quote expr env) + (let ((obj (cadr expr))) + (if (or (boolean? obj) + (number? obj) + (string? obj)) + obj + (list (simplify-identifiers $quote env) + (unpaint obj))))) + + (define (expand-quasiquote expr env) + (list (simplify-identifiers $quasiquote env) + (let qq ((expr (cadr expr)) + (level 0)) + (cond ((vector? expr) + (list->vector (qq (vector->list expr) level))) + ((not (pair? expr)) + (unpaint expr)) + ((not (identifier? (car expr))) + (cons (qq (car expr) level) (qq (cdr expr) level))) + ((identifier-equal? (car expr) $quasiquote env) + (list (simplify-identifiers $quasiquote env) + (qq (cadr expr) (+ level 1)))) + ((or (identifier-equal? (car expr) $unquote env) + (identifier-equal? (car expr) $unquote-splicing env)) + (list (simplify-identifiers (car expr) env) + (if (zero? level) + (macro:expand (cadr expr) env) + (qq (cadr expr) (- level 1))))) + (else + (cons (qq (car expr) level) + (qq (cdr expr) level))))))) + + (define (expand-case expr env) + (cons (simplify-identifiers $case env) + (cons (macro:expand (cadr expr) env) + (map (lambda (clause) + (cond ((pair? (car clause)) + (cons (unpaint (car clause)) + (expand* (cdr clause) env))) + ((and (identifier? (car clause)) + (identifier-equal? $else + (car clause) env)) + (cons (simplify-identifiers + (car clause) env) + (expand* (cdr clause) env))) + (else (error 'macro:expand 'case + "bad clause" expr)))) + (cddr expr))))) + + (define (expand-cond expr env) + (cons (simplify-identifiers $cond env) + (map (lambda (clause) (expand* clause env)) + (cdr expr)))) + + ;; for IF, BEGIN, SET! + (define (expand-simple expr env) + (cons (simplify-identifiers (car expr) env) + (expand* (cdr expr) env))) + + (define (expand-primitives expr env) + (let loop ((expr (list '@expand expr))) + (let* ((expanded (expander expr env)) + (head (car expanded))) + (cond ((identifier-equal? @LAMBDA head env) + (expand-lambda expanded env)) + ((identifier-equal? @LET head env) + (expand-let expanded env)) + ((identifier-equal? @LET* head env) + (expand-let* expanded env)) + ((identifier-equal? @LETREC head env) + (expand-letrec expanded env)) + ((identifier-equal? @DO head env) + (expand-do expanded env)) + ((identifier-equal? $QUOTE head env) + (expand-quote expanded env)) + ((identifier-equal? $QUASIQUOTE head env) + (expand-quasiquote expanded env)) + ((identifier-equal? $BEGIN head env) + (expand-simple expanded env)) + ((identifier-equal? $IF head env) + (expand-simple expanded env)) + ((identifier-equal? $AND head env) + (expand-simple expanded env)) + ((identifier-equal? $OR head env) + (expand-simple expanded env)) + ((identifier-equal? $SET! head env) + (expand-simple expanded env)) + ((identifier-equal? $DELAY head env) + (expand-simple expanded env)) + ((identifier-equal? $@APPLY head env) + (expand-simple expanded env)) + ((identifier-equal? $CASE head env) + (expand-case expanded env)) + ((identifier-equal? $COND head env) + (expand-cond expanded env)) + ((and (identifier-equal? $DEFINE head env) + (null? (environment->tree env))) + (expand-define expanded env)) + ((identifier-equal? $SYNTAX-QUOTE head env) + (cons (simplify-identifiers head env) + (cdr expanded))) + ((identifier-equal? @EXPAND head env) + (loop expanded)) + (else + (print 'macro:expand + "Warning: unknown primitive syntax" (car expanded)) + expanded))))) + + (lambda (expr env) + (let loop ((expr expr)) + (let ((expanded (@macroexpand1 expr env))) + (cond ((not expanded) + (cond ((pair? expr) + (if (list? expr) + (expand* expr env) + (print 'macro:expand "expansion not a list" expr))) + ((identifier? expr) + (simplify-identifiers expr env)) + (else expr))) + ((eq? expanded expr) + (expand-primitives expr env)) + (else + (loop expanded)))))))) + +;;; Local Variables: +;;; eval: (put 'identifier-case 'scheme-indent-function 1) +;;; End: |