summaryrefslogtreecommitdiffstats
path: root/Macroexpand.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitdeda2c0fd8689349fea2a900199a76ff7ecb319e (patch)
treec9726d54a0806a9b0c75e6c82db8692aea0053cf /Macroexpand.scm
parent3278b75942bdbe706f7a0fba87729bb1e935b68b (diff)
downloadscm-deda2c0fd8689349fea2a900199a76ff7ecb319e.tar.gz
scm-deda2c0fd8689349fea2a900199a76ff7ecb319e.zip
Import Upstream version 5d6upstream/5d6
Diffstat (limited to 'Macroexpand.scm')
-rw-r--r--Macroexpand.scm370
1 files changed, 0 insertions, 370 deletions
diff --git a/Macroexpand.scm b/Macroexpand.scm
deleted file mode 100644
index 3b658f8..0000000
--- a/Macroexpand.scm
+++ /dev/null
@@ -1,370 +0,0 @@
-;; 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: