diff options
| author | LaMont Jones <lamont@debian.org> | 2003-05-07 08:36:40 -0600 | 
|---|---|---|
| committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:27 -0800 | 
| commit | e21d47d7813159bb71e0671df9b52ec0470c358d (patch) | |
| tree | 3c7770ea846123c291f599044e9f234ac17616bb /Macroexpand.scm | |
| parent | 8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693 (diff) | |
| parent | deda2c0fd8689349fea2a900199a76ff7ecb319e (diff) | |
| download | scm-e21d47d7813159bb71e0671df9b52ec0470c358d.tar.gz scm-e21d47d7813159bb71e0671df9b52ec0470c358d.zip | |
Import Debian changes 5d6-3.2debian/5d6-3.2
scm (5d6-3.2) unstable; urgency=low
  * Fix hppa compile.  Closes: #144062
scm (5d6-3.1) unstable; urgency=low
  * NMU with patch from James Troup, to fix FTBFS on sparc. Closes: #191171
scm (5d6-3) unstable; urgency=low
  * Add build depend on xlibs-dev (Closes: #148020)
scm (5d6-2) unstable; urgency=low
  * Remove libregexx-dev from build-depends.
  * Change build to use ./scmlit rather than scmlit (should fix some build
    problems) (looks like alpha is mostly building)
  * New release (Closes: #140175)
  * Built with turtlegraphics last time (Closes: #58515)
scm (5d6-1) unstable; urgency=low
  * New upstream.
  * Add xlib and turtlegr to requested list of features. (closes
    some bug)
  * Make clean actually clean most everything up.
  * Remove hacks renaming build to something else and just set build as a
    .PHONY target in debian/rules.
  * Add the turtlegr code.
scm (5d5-1) unstable; urgency=low
  * New upstream
  * Has fixes for 64 bit archs.  May fix alpha compile problem.  Does fix
    (Closes: #140175)
  * Take out -O2 arg.
scm (5d4-3) unstable; urgency=low
  * Don't link with regexx, but just use libc6's regular expression
    functions.
  * Define (terms) to output /usr/share/common-licenses/GPL (Closes:
    #119321) 
scm (5d4-2) unstable; urgency=low
  * Add texinfo to build depends (Closes: #107011)
scm (5d4-1) unstable; urgency=low
  * New upstream release.
  * Move install-info --remove to prerm.
scm (5d3-5) unstable; urgency=low
  * Move scm info files to section "The Algorithmic Language Scheme" to
    match up with guile.
scm (5d3-4) unstable; urgency=low
  * Fix build depends (Closes: #76691)
scm (5d3-3) unstable; urgency=low
  * Fix path in scm dhelp file.
scm (5d3-2) unstable; urgency=low
  * Actually put the header files in the package.  Oops.
scm (5d3-1) unstable; urgency=low
  * New upstream. (Closes: #74761)
  * Make (terms) use new license location.
  * Make use libregexx rather than librx.
  * Fix build depends for above.
  * Using new regex lib seems to fix crash (Closes: #66787)
  * Consider adding scm-dev package with headers, but instead just add the
    headers to the scm package. (Closes: #70787)
  * Add doc-base support.
Diffstat (limited to 'Macroexpand.scm')
| -rw-r--r-- | Macroexpand.scm | 370 | 
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: | 
