head	1.17;
access;
symbols;
locks; strict;
comment	@# @;


1.17
date	2005.03.26.19.57.44;	author al;	state Exp;
branches;
next	1.16;

1.16
date	2004.10.29.21.06.51;	author al;	state Exp;
branches;
next	1.15;

1.15
date	2004.09.28.06.08.10;	author al;	state Exp;
branches;
next	1.14;

1.14
date	2004.09.28.01.04.24;	author al;	state Exp;
branches;
next	1.13;

1.13
date	2002.09.25.20.14.24;	author al;	state Exp;
branches;
next	1.12;

1.12
date	2002.06.17.23.33.17;	author al;	state Exp;
branches;
next	1.11;

1.11
date	2002.06.17.19.27.00;	author al;	state Exp;
branches;
next	1.10;

1.10
date	2002.06.12.23.15.22;	author al;	state Exp;
branches;
next	1.9;

1.9
date	2002.06.09.22.00.12;	author al;	state Exp;
branches;
next	1.8;

1.8
date	2002.05.29.04.51.11;	author al;	state Exp;
branches;
next	1.7;

1.7
date	2002.05.28.21.22.55;	author al;	state Exp;
branches;
next	1.6;

1.6
date	2002.05.28.18.47.42;	author al;	state Exp;
branches;
next	1.5;

1.5
date	2002.05.28.04.48.53;	author al;	state Exp;
branches;
next	1.4;

1.4
date	2002.05.22.00.07.23;	author al;	state Exp;
branches;
next	1.3;

1.3
date	2002.05.21.05.10.49;	author al;	state Exp;
branches;
next	1.2;

1.2
date	2002.05.21.01.35.47;	author al;	state Exp;
branches;
next	1.1;

1.1
date	2002.05.21.00.16.06;	author al;	state Exp;
branches;
next	;


desc
@@


1.17
log
@Fixed evaluation of internal definition initializers to use MAP1
rather than MAP, for the same reason that evaluation of combination
positions was changed to MAP1 in revision 1.14.
@
text
@;; eiod.scm: eval-in-one-define
;; $Id: eiod.scm,v 1.16 2004/10/29 21:06:51 al Exp al $

;; A minimal implementation of r5rs eval, null-environment, and
;; scheme-report-environment.  (And SRFI-46 extensions, too.)

;; Copyright 2002, 2004, 2005 Al Petrofsky <al@@petrofsky.org>

;; You may redistribute and/or modify this software under the terms of
;; the GNU General Public License as published by the Free Software
;; Foundation (fsf.org); either version 2, or (at your option) any
;; later version.

;; Feel free to ask me for different licensing terms. 

;; DISCLAIMER: 

;; This is only intended as a demonstration of the minimum
;; implementation effort required for an r5rs eval.  It serves as a
;; simple, working example of one way to implement the r5rs macro
;; system (and SRFI-46) .  Among the reasons that it is ill-suited for
;; production use is the complete lack of error-checking.

;; DATA STRUCTURES:

;; An environment is a procedure that accepts any identifier and
;; returns a denotation.  The denotation of an unbound identifier is
;; its name (as a symbol).  A bound identifier's denotation is its
;; binding, which is a list of the current value, the binding's type
;; (keyword or variable), and the identifier's name (needed by quote).

;; identifier:       [symbol | thunk]
;; denotation:       [symbol | binding]
;; binding:          [variable-binding | keyword-binding]
;; variable-binding: (value        #f symbol)
;; keyword-binding:  (special-form #t symbol)
;; special-form:     [builtin | transformer]

;; A value is any arbitrary scheme value.  Special forms are either a
;; symbol naming a builtin, or a transformer procedure that takes two
;; arguments: a macro use and the environment of the macro use.

;; An explicit-renaming low-level macro facility is supported, upon
;; which syntax-rules is implemented.  When a syntax-rules template
;; containing a literal identifier is transcribed, the output will
;; contain a fresh identifier, which is an eq?-unique thunk that when
;; invoked returns the old identifier's denotation in the environment
;; of the macro's definition.  When one of these "renamed" identifiers
;; is looked up in an environment that has no binding for it, the
;; thunk is invoked and the old denotation is returned.  (The thunk
;; actually returns the old denotation wrapped inside a unique pair,
;; which is immediately unwrapped.  This is necessary to ensure that
;; different rename thunks of the same denotation do not compare eq?.)

;; This environment and denotation model is similar to the one
;; described in the 1991 paper "Macros that Work" by Clinger and Rees.

;; The base environment contains eight keyword bindings and two
;; variable bindings:
;;   lambda, set!, and begin are as in the standard.
;;   q is like quote, but it does not handle pairs or vectors.
;;   def is like define, but it does not handle the (f . args) format.
;;   define-syntax makes internal syntax definitions.
;;   (get-env) returns the local environment.
;;   (syntax x) is like quote, but does not convert identifiers to symbols.
;;   The id? procedure is a predicate for identifiers.
;;   The new-id procedure takes a denotation and returns a fresh identifier.


;; Quote-and-evaluate captures all the code into the list eiod-source
;; so that we can have fun feeding eval to itself, as in
;; ((eval `(let () ,@@eiod-source repl) (scheme-report-environment 5))).
;; [Note: using (and even starting) a doubly evaled repl will be *very* slow.]
(define-syntax quote-and-evaluate
  (syntax-rules () ((quote-and-evaluate var . x) (begin (define var 'x) . x))))

;; The matching close parenthesis is at the end of the file.
(quote-and-evaluate eiod-source

(define (eval sexp env)
  (define (new-id den)    (define p (list den)) (lambda () p))
  (define (old-den id)    (car (id)))
  (define (id? x)         (or (symbol? x) (procedure? x)))
  (define (id->sym id)    (if (symbol? id) id (den->sym (old-den id))))
  (define (den->sym den)  (if (symbol? den) den (get-sym den)))

  (define (empty-env id)          (if (symbol? id) id (old-den id)))
  (define (extend env id binding) (lambda (i) (if (eq? id i) binding (env i))))
  (define (add-var var val env)   (extend env var (list val #f (id->sym var))))
  (define (add-key key val env)   (extend env key (list val #t (id->sym key))))

  (define (get-val  binding)      (car binding))
  (define (special? binding)      (cadr binding))
  (define (get-sym  binding)      (caddr binding))
  (define (set-val! binding val)  (set-car! binding val))

  (define (make-builtins-env)
    (do ((specials '(lambda set! begin q def define-syntax syntax get-env)
		   (cdr specials))
	 (env empty-env (add-key (car specials) (car specials) env)))
	((null? specials) (add-var 'new-id new-id (add-var 'id? id? env)))))

  (define (eval sexp env)
    (let eval-here ((sexp sexp))
      (cond ((id? sexp) (get-val (env sexp)))
	    ((not (pair? sexp)) sexp)
	    (else (let ((head (car sexp)) (tail (cdr sexp)))
		    (let ((head-binding (and (id? head) (env head))))
		      (if (and head-binding (special? head-binding))
			  (let ((special (get-val head-binding)))
			    (case special
			      ((get-env) env)
			      ((syntax) (car tail))
			      ((lambda) (eval-lambda tail env))
			      ((begin) (eval-seq tail env))
			      ((set!) (set-val! (env (car tail))
						(eval-here (cadr tail))))
			      ((q) (let ((x (car tail)))
				     (if (id? x) (id->sym x) x)))
			      (else (eval-here (special sexp env)))))
			  (apply (eval-here head)
				 (map1 eval-here tail)))))))))

  ;; Don't use standard map because it might not be continuationally correct.
  (define (map1 f l)
    (if (null? l)
	'()
	(cons (f (car l)) (map1 f (cdr l)))))

  (define (eval-seq tail env)
    ;; Don't use for-each because we must tail-call the last expression.
    (do ((sexps tail (cdr sexps)))
	((null? (cdr sexps)) (eval (car sexps) env))
      (eval (car sexps) env)))

  (define (eval-lambda tail env)
    (lambda args
      (define ienv (do ((args args (cdr args))
			(vars (car tail) (cdr vars))
			(ienv env (add-var (car vars) (car args) ienv)))
		       ((not (pair? vars))
			(if (null? vars) ienv (add-var vars args ienv)))))
      (let loop ((ienv ienv) (ids '()) (inits '()) (body (cdr tail)))
	(let ((first (car body)) (rest (cdr body)))
	  (let* ((head (and (pair? first) (car first)))
		 (binding (and (id? head) (ienv head)))
		 (special (and binding (special? binding) (get-val binding))))
	    (if (procedure? special)
		(loop ienv ids inits (cons (special first ienv) rest))
		(case special
		  ((begin) (loop ienv ids inits (append (cdr first) rest)))
		  ((def define-syntax)
		   (let ((id (cadr first)) (init (caddr first)))
		     (let* ((adder (if (eq? special 'def) add-var add-key))
			    (ienv (adder id 'undefined ienv)))
		       (loop ienv (cons id ids) (cons init inits) rest))))
		  (else (let ((ieval (lambda (init) (eval init ienv))))
			  (for-each set-val! (map ienv ids) (map1 ieval inits))
			  (eval-seq body ienv))))))))))

  ;; We make a copy of the initial input to ensure that subsequent
  ;; mutation of it does not affect eval's result. [1]
  (eval (let copy ((x sexp))
	  (cond ((string? x) (string-copy x))
		((pair? x) (cons (copy (car x)) (copy (cdr x))))
		((vector? x) (list->vector (copy (vector->list x))))
		(else x)))
	(or env (make-builtins-env))))


(define null-environment
  (let ()
    ;; Syntax-rules is implemented as a macro that expands into a call
    ;; to the syntax-rules* procedure, which returns a transformer
    ;; procedure.  The arguments to syntax-rules* are the arguments to
    ;; syntax-rules plus the current environment, which is captured
    ;; with get-env.  Syntax-rules** is called once with some basics
    ;; from the base environment.  It creates and returns
    ;; syntax-rules*.
    (define (syntax-rules** id? new-id denotation-of-default-ellipsis)
      (define (syntax-rules* mac-env ellipsis pat-literals rules)
        (define (pat-literal? id)     (memq id pat-literals))
	(define (not-pat-literal? id) (not (pat-literal? id)))
	(define (ellipsis-pair? x)    (and (pair? x) (ellipsis? (car x))))
	(define (ellipsis? x)
	  (if ellipsis
	      (eq? x ellipsis)
	      (and (id? x)
		   (eq? (mac-env x) denotation-of-default-ellipsis))))

	;; List-ids returns a list of the non-ellipsis ids in a
	;; pattern or template for which (pred? id) is true.  If
	;; include-scalars is false, we only include ids that are
	;; within the scope of at least one ellipsis.
	(define (list-ids x include-scalars pred?)
	  (let collect ((x x) (inc include-scalars) (l '()))
	    (cond ((id? x) (if (and inc (pred? x)) (cons x l) l))
		  ((vector? x) (collect (vector->list x) inc l))
		  ((pair? x)
		   (if (ellipsis-pair? (cdr x))
		       (collect (car x) #t (collect (cddr x) inc l))
		       (collect (car x) inc (collect (cdr x) inc l))))
		  (else l))))
    
	;; Returns #f or an alist mapping each pattern var to a part of
	;; the input.  Ellipsis vars are mapped to lists of parts (or
	;; lists of lists ...).
	(define (match-pattern pat use use-env)
	  (call-with-current-continuation
	    (lambda (return)
	      (define (fail) (return #f))
	      (let match ((pat (cdr pat)) (sexp (cdr use)) (bindings '()))
		(define (continue-if condition) (if condition bindings (fail)))
		(cond
		 ((id? pat)
		  (if (pat-literal? pat)
		      (continue-if (and (id? sexp)
					(eq? (use-env sexp) (mac-env pat))))
		      (cons (cons pat sexp) bindings)))
		 ((vector? pat)
		  (or (vector? sexp) (fail))
		  (match (vector->list pat) (vector->list sexp) bindings))
		 ((not (pair? pat)) (continue-if (equal? pat sexp)))
		 ((ellipsis-pair? (cdr pat))
		  (let* ((tail-len (length (cddr pat)))
			 (sexp-len (if (list? sexp) (length sexp) (fail)))
			 (seq-len (- sexp-len tail-len))
			 (sexp-tail (begin (if (negative? seq-len) (fail))
					   (list-tail sexp seq-len)))
			 (seq (reverse (list-tail (reverse sexp) tail-len)))
			 (vars (list-ids (car pat) #t not-pat-literal?)))
		    (define (match1 sexp) (map cdr (match (car pat) sexp '())))
		    (append (apply map list vars (map match1 seq))
			    (match (cddr pat) sexp-tail bindings))))
		 ((pair? sexp) (match (car pat) (car sexp)
				      (match (cdr pat) (cdr sexp) bindings)))
		 (else (fail)))))))

	(define (expand-template pat tmpl top-bindings)
	  ;; New-literals is an alist mapping each literal id in the
	  ;; template to a fresh id for inserting into the output.  It
	  ;; might have duplicate entries mapping an id to two different
	  ;; fresh ids, but that's okay because when we go to retrieve a
	  ;; fresh id, assq will always retrieve the first one.
	  (define new-literals
	    (map (lambda (id) (cons id (new-id (mac-env id))))
		 (list-ids tmpl #t (lambda (id)
				     (not (assq id top-bindings))))))
	  (define ellipsis-vars (list-ids (cdr pat) #f not-pat-literal?))
	  (define (list-ellipsis-vars subtmpl)
	    (list-ids subtmpl #t (lambda (id) (memq id ellipsis-vars))))
	  (let expand ((tmpl tmpl) (bindings top-bindings))
	    (let expand-part ((tmpl tmpl))
	      (cond
	       ((id? tmpl) (cdr (or (assq tmpl bindings)
				    (assq tmpl top-bindings)
				    (assq tmpl new-literals))))
	       ((vector? tmpl)
		(list->vector (expand-part (vector->list tmpl))))
	       ((pair? tmpl)
		(if (ellipsis-pair? (cdr tmpl))
		    (let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
		      (define (lookup var) (cdr (assq var bindings)))
		      (define (expand-using-vals . vals)
			(expand (car tmpl) (map cons vars-to-iterate vals)))
		      (let ((val-lists (map lookup vars-to-iterate)))
			(append (apply map expand-using-vals val-lists)
				(expand-part (cddr tmpl)))))
		    (cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
	       (else tmpl)))))

	(lambda (use use-env)
	  (let loop ((rules rules))
	    (let* ((rule (car rules)) (pat (car rule)) (tmpl (cadr rule)))
	      (cond ((match-pattern pat use use-env) =>
		     (lambda (bindings) (expand-template pat tmpl bindings)))
		    (else (loop (cdr rules))))))))
      syntax-rules*)
    (define macro-defs
      '((define-syntax quote
	  (syntax-rules ()
	    ('(x . y) (cons 'x 'y))
	    ('#(x ...) (list->vector '(x ...)))
	    ('x (q x))))
	(define-syntax quasiquote
	  (syntax-rules (unquote unquote-splicing quasiquote)
	    (`,x x)
	    (`(,@@x . y) (append x `y))
	    ((_ `x . d) (cons 'quasiquote       (quasiquote (x)   d)))
	    ((_ ,x   d) (cons 'unquote          (quasiquote (x) . d)))
	    ((_ ,@@x  d) (cons 'unquote-splicing (quasiquote (x) . d)))
	    ((_ (x . y) . d)
	     (cons (quasiquote x . d) (quasiquote y . d)))
	    ((_ #(x ...) . d)
	     (list->vector (quasiquote (x ...) . d)))
	    ((_ x . d) 'x)))
	(define-syntax do
	  (syntax-rules ()
	    ((_ ((var init . step) ...)
		ending
		expr ...)
	     (let loop ((var init) ...)
	       (cond ending (else expr ... (loop (begin var . step) ...)))))))
	(define-syntax letrec
	  (syntax-rules ()
	    ((_ ((var init) ...) . body)
	     (let () (def var init) ... (let () . body)))))
	(define-syntax letrec-syntax
	  (syntax-rules ()
	    ((_ ((key trans) ...) . body)
	     (let () (define-syntax key trans) ... (let () . body)))))
	(define-syntax let-syntax
	  (syntax-rules ()
	    ((_ () . body) (let () . body))
	    ((_ ((key trans) . bindings) . body)
	     (letrec-syntax ((temp trans))
	       (let-syntax bindings (letrec-syntax ((key temp)) . body))))))
	(define-syntax let*
	  (syntax-rules ()
	    ((_ () . body) (let () . body))
	    ((_ (first . more) . body)
	     (let (first) (let* more . body)))))
	(define-syntax let
	  (syntax-rules ()
	    ((_ ((var init) ...) . body)
	     ((lambda (var ...) . body)
	      init ...))
	    ((_ name ((var init) ...) . body)
	     ((letrec ((name (lambda (var ...) . body)))
		name)
	      init ...))))
	(define-syntax case
	  (syntax-rules ()
	    ((_ x (test . exprs) ...)
	     (let ((key x))
	       (cond ((case-test key test) . exprs)
		     ...)))))
	(define-syntax case-test
	  (syntax-rules (else) ((_ k else) #t) ((_ k atoms) (memv k 'atoms))))
	(define-syntax cond
	  (syntax-rules (else =>)
	    ((_) #f)
	    ((_ (else . exps)) (begin #f . exps))
	    ((_ (x) . rest) (or x (cond . rest)))
	    ((_ (x => proc) . rest)
	     (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
	    ((_ (x . exps) . rest)
	     (if x (begin . exps) (cond . rest)))))
	(define-syntax and
	  (syntax-rules ()
	    ((_) #t)
	    ((_ test) test)
	    ((_ test . tests) (if test (and . tests) #f))))
	(define-syntax or
	  (syntax-rules ()
	    ((_) #f)
	    ((_ test) test)
	    ((_ test . tests) (let ((x test)) (if x x (or . tests))))))
	(define-syntax define
	  (syntax-rules ()
	    ((_ (var . args) . body)
	     (define var (lambda args . body)))
	    ((_ var init) (def var init))))
	(define-syntax if
	  (syntax-rules () ((_ x y ...) (if* x (lambda () y) ...))))
	(define-syntax delay
	  (syntax-rules () ((_ x) (delay* (lambda () x)))))))
    (define (if* a b . c) (if a (b) (if (pair? c) ((car c)))))
    (define (delay* thunk) (delay (thunk)))
    (define (null-env)
      ((eval `(lambda (cons append list->vector memv delay* if* syntax-rules**)
		((lambda (syntax-rules*)
		   (define-syntax syntax-rules
		     (syntax-rules* (get-env) #f (syntax ())
		       (syntax (((_ (lit ...) . rules)
				 (syntax-rules #f (lit ...) . rules))
				((_ ellipsis lits . rules)
				 (syntax-rules* (get-env) (syntax ellipsis)
				   (syntax lits) (syntax rules)))))))
		   ((lambda () ,@@macro-defs (get-env))))
		 (syntax-rules** id? new-id ((get-env) (syntax ...)))))
	     #f)
       cons append list->vector memv delay* if* syntax-rules**))
    (define promise (delay (null-env)))
    (lambda (version)
      (if (= version 5)
          (force promise)
          (open-input-file "sheep-herders/r^-1rs.ltx")))))


(define scheme-report-environment
  (let-syntax
      ((extend-env
	(syntax-rules ()
	  ((extend-env env . names)
	   ((eval '(lambda names (get-env)) env)
	    . names)))))
    (let ()
      (define (r5-env)
	(extend-env (null-environment 5)
	  eqv? eq? equal?
	  number? complex? real? rational? integer? exact? inexact?
	  = < > <= >= zero? positive? negative? odd? even?
	  max min + * - /
	  abs quotient remainder modulo gcd lcm numerator denominator
	  floor ceiling truncate round rationalize
	  exp log sin cos tan asin acos atan sqrt expt
	  make-rectangular make-polar real-part imag-part magnitude angle
	  exact->inexact inexact->exact
	  number->string string->number
	  not boolean?
	  pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr
	  caaar caadr cadar caddr cdaar cdadr cddar cdddr
	  caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
	  cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
	  null? list? list length append reverse list-tail list-ref
	  memq memv member assq assv assoc
	  symbol? symbol->string string->symbol
	  char? char=? char<? char>? char<=? char>=?
	  char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
	  char-alphabetic? char-numeric? char-whitespace?
	  char-upper-case? char-lower-case?
	  char->integer integer->char char-upcase char-downcase
	  string? make-string string string-length string-ref string-set!
	  string=? string-ci=? string<? string>? string<=? string>=?
	  string-ci<? string-ci>? string-ci<=? string-ci>=?
	  substring string-append string->list list->string
	  string-copy string-fill!
	  vector? make-vector vector vector-length vector-ref vector-set!
	  vector->list list->vector vector-fill!
	  procedure? apply map for-each force
	  call-with-current-continuation
	  values call-with-values dynamic-wind
	  eval scheme-report-environment null-environment
	  call-with-input-file call-with-output-file
	  input-port? output-port? current-input-port current-output-port
	  with-input-from-file with-output-to-file
	  open-input-file open-output-file close-input-port close-output-port
	  read read-char peek-char eof-object? char-ready?
	  write display newline write-char))
      (define promise (delay (r5-env)))
      (lambda (version)
	(if (= version 5)
	    (force promise)
	    (open-input-file "sheep-herders/r^-1rs.ltx"))))))

;; [1] Some claim that this is not required, and that it is compliant for
;;
;;   (let* ((x (string #\a))
;;          (y (eval x (null-environment 5))))
;;     (string-set! x 0 #\b)
;;     y)
;;
;; to return "b", but I say that's as bogus as if
;;
;;   (let* ((x (string #\1))
;;          (y (string->number x)))
;;     (string-set! x 0 #\2)
;;     y)
;;
;; returned 2.  Most implementations disagree with me, however.
;;
;; Note: it would be fine to pass through those strings (and pairs and
;; vectors) that are immutable, but we can't portably detect them.


;; Repl provides a simple read-eval-print loop.  It semi-supports
;; top-level definitions and syntax definitions, but each one creates
;; a new binding whose region does not include anything that came
;; before the definition, so if you want mutually recursive top-level
;; procedures, you have to do it the hard way:
;;   (define f #f)
;;   (define (g) (f))
;;   (set! f (lambda () (g)))
;; Repl does not support macro uses that expand into top-level definitions.
(define (repl)
  (let repl ((env (scheme-report-environment 5)))
    (display "eiod> ")
    (let ((exp (read)))
      (if (not (eof-object? exp))
	  (case (and (pair? exp) (car exp))
	    ((define define-syntax) (repl (eval `(let () ,exp (get-env))
						env)))
	    (else
	     (for-each (lambda (val) (write val) (newline))
		       (call-with-values (lambda () (eval exp env))
			 list))
	     (repl env)))))))

(define (tests noisy)
  (define env (scheme-report-environment 5))
  (for-each
   (lambda (x)
     (let* ((exp (car x))
	    (expected (cadr x)))
       (if noisy (begin (display "Trying: ") (write exp) (newline)))
       (let* ((result (eval exp env))
	      (success (equal? result expected)))
	 (if (not success) 
	     (begin (display "Failed: ")
		    (if (not noisy) (write exp))
		    (display " returned ")
		    (write result)
		    (display ", not ")
		    (write expected)
		    (newline))))))
   '((1 1)
     (#t #t)
     ("hi" "hi")
     (#\a #\a)
     ('1 1)
     ('foo foo)
     ('(a b) (a b))
     ('#(a b) #(a b))
     (((lambda (x) x) 1) 1)
     ((+ 1 2) 3)
     (((lambda (x) (set! x 2) x) 1) 2)
     (((lambda () (define x 1) x)) 1)
     (((lambda () (define (x) 1) (x))) 1)
     ((begin 1 2) 2)
     (((lambda () (begin (define x 1)) x)) 1)
     (((lambda () (begin) 1)) 1)
     ((let-syntax ((f (syntax-rules () ((_) 1)))) (f)) 1)
     ((letrec-syntax ((f (syntax-rules () ((_) (f 1)) ((_ x) x)))) (f)) 1)
     ((let-syntax ((f (syntax-rules () ((_ x ...) '(x ...))))) (f 1 2)) (1 2))
     ((let-syntax ((f (syntax-rules ()
			((_ (x y) ...) '(x ... y ...))
			((_ x ...) '(x ...)))))
	(f (x1 y1) (x2 y2)))
      (x1 x2 y1 y2))
     ((let-syntax ((let (syntax-rules ()
			  ((_ ((var init) ...) . body)
			   '((lambda (var ...) . body) init ...)))))
	(let ((x 1) (y 2)) (+ x y)))
      ((lambda (x y) (+ x y)) 1 2))
     ((let ((x 1)) x) 1)
     ((let* ((x 1) (x (+ x 1))) x) 2)
     ((let ((call/cc call-with-current-continuation))
	(letrec ((x (call/cc list)) (y (call/cc list)))
	  (if (procedure? x) (x (pair? y))) 
	  (if (procedure? y) (y (pair? x)))
	  (let ((x (car x)) (y (car y)))
	    (and (call/cc x) (call/cc y) (call/cc x)))))
      #t)
     ((if 1 2) 2)
     ((if #f 2 3) 3)
     ((and 1 #f 2) #f)
     ((force (delay 1)) 1)
     ((let* ((x 0) (p (delay (begin (set! x (+ x 1)) x)))) (force p) (force p))
      1)
     ((let-syntax
	  ((foo (syntax-rules ()
		  ((_ (x ...) #(y z ...) ...)
		   '((z ...) ... #((x y) ...))))))
	(foo (a b c) #(1 i j) #(2 k l) #(3 m n)))
      ((i j) (k l) (m n) #((a 1) (b 2) (c 3))))
     ((do ((vec (make-vector 5))
	   (i 0 (+ i 1)))
	  ((= i 5) vec)
	(vector-set! vec i i))
      #(0 1 2 3 4))
     ((let-syntax ((f (syntax-rules (x) ((_ x) 1) ((_ y) 2))))
	(define x (f x))
	x)
      2)
     ((let-syntax ((f (syntax-rules () ((_) 'x)))) (f))
      x)
     ((let-syntax ((f (syntax-rules ()
			((_) (let ((x 1))
			       (let-syntax ((f (syntax-rules () ((_) 'x))))
				 (f)))))))
	(f))
      x)
     ((let-syntax
	  ((f (syntax-rules ()
		((f e a ...)
		 (let-syntax
		     ((g (syntax-rules ::: ()
			   ((g n :::) '((a e n :::) ...)))))
		   (g 1 2 3))))))
	(f ::: x y z))
      ((x ::: 1 2 3) (y ::: 1 2 3) (z ::: 1 2 3)))
     ((let-syntax ((m (syntax-rules () ((m x ... y) (y x ...)))))
	(m 1 2 3 -))
      -4))))

;; matching close paren for quote-and-evaluate at beginning of file.
) 

@


1.16
log
@Added SRFI-46 support:  Choose-your-own-ellipsis and post-ellipsis patterns.
Expanded disclaimer.
@
text
@d2 1
a2 1
;; $Id: eiod.scm,v 1.15 2004/09/28 06:08:10 al Exp al $
d7 1
a7 1
;; Copyright 2002, 2004 Al Petrofsky <al@@petrofsky.org>
d158 2
a159 2
			  (for-each set-val! (map ienv ids) (map ieval inits)))
			(eval-seq body ienv)))))))))
@


1.15
log
@Added SRFI-46 Choose-Your-Own-Ellipsis feature and test case.

Added comment explaining syntax-rules**, syntax-rules*, and
syntax-rules.
@
text
@d2 1
a2 1
;; $Id: eiod.scm,v 1.14 2004/09/28 01:04:24 al Exp al $
d5 1
a5 1
;; scheme-report-environment.
d7 1
a7 1
;; Copyright 2002 Al Petrofsky <al@@petrofsky.org>
d14 11
a24 1
;; Data Structures:
d174 6
a179 5
    ;; to the syntax-rules* procedure.  The arguments to syntax-rules*
    ;; are the arguments to syntax-rules plus the current environment,
    ;; which is captured with get-env.  Syntax-rules** is called once
    ;; with some basics from the top-level environment: it creates and
    ;; returns syntax-rules*.
d186 3
a188 3
	  (and (id? x)
	       (if ellipsis
		   (eq? x ellipsis)
d207 2
a208 2
	;; lists of lists...).
	(define (match-pattern pat use env)
d215 5
a219 4
		 ((id? pat) (if (pat-literal? pat)
				(continue-if (and (id? sexp) (eq? (mac-env pat)
								  (env sexp))))
				(cons (cons pat sexp) bindings)))
d225 7
a231 2
		  (or (list? sexp) (fail))
		  (let ((vars (list-ids pat #t not-pat-literal?)))
d233 2
a234 2
		    (append (apply map list vars (map match1 sexp))
			    bindings)))
d264 1
a264 1
		      (define (expand-car . vals)
d266 3
a268 3
		      (append (apply map expand-car
				     (map lookup vars-to-iterate))
			      (expand-part (cddr tmpl))))
d272 1
a272 1
	(lambda (use env)
d275 1
a275 1
	      (cond ((match-pattern pat use env) =>
d582 4
a585 1
      ((x ::: 1 2 3) (y ::: 1 2 3) (z ::: 1 2 3))))))
@


1.14
log
@(Checking in some old changes.)

In the two places where we use the host syntax-rules, the keyword in
the patterns is now the keyword being bound, rather than "_" (this is
arguably required by r5rs).

Renamed eval-begin to eval-seq (because it only handles expression
sequences, and does not allow definitions like BEGIN does).

Wrote a private version of MAP, because r5rs clearly requires (in the
formal semantics section) the continuations of combination positions
to be handled a certain way, but the r5rs specification for MAP does
not clearly specify what continuations captured during a MAP do.
@
text
@d2 1
a2 1
;; $Id$
d163 8
a170 2
    (define (syntax-rules** id? new-id top-env ellipsis)
      (lambda (mac-env pat-literals rules)
a172 2
	(define (ellipsis? x)         (and (id? x) (eq? (mac-env x)
							(top-env ellipsis))))
d174 5
d260 2
a261 1
		    (else (loop (cdr rules)))))))))
d357 6
a362 4
		     (syntax-rules* (get-env) (syntax ())
		       (syntax (((_ lits . rules)
				 (syntax-rules* (get-env) (syntax lits)
				   (syntax rules)))))))
d364 1
a364 1
		 (syntax-rules** id? new-id (get-env) (syntax ...))))
d556 10
a565 1
      x))))
@


1.13
log
@Added GPL notice.
Changed order of the elements of a binding, so as to simplify set-val! a bit.
About to announce on comp.lang.scheme.
@
text
@d2 1
a2 1
;; $Id: eiod-simple.scm,v 1.12 2002/06/17 23:33:17 al Exp al $
d65 1
a65 1
  (syntax-rules () ((_ var . x) (begin (define var 'x) . x))))
d105 1
a105 1
			      ((begin) (eval-begin tail env))
d111 2
a112 1
			  (apply (eval-here head) (map eval-here tail)))))))))
d114 7
a120 1
  (define (eval-begin tail env)
d149 1
a149 1
			(eval-begin body ienv)))))))))
d366 1
a366 1
	  ((_ env . names)
@


1.12
log
@Bindings now contain the identifier's original symbolic name, rather
than the next previous identifier, so den->sym no longer has to
recursively call id->sym.
@
text
@d2 2
a3 3
;; Copyright 2002 Al Petrofsky <al@@petrofsky.org>
;; $Id: eiod-simple.scm,v 1.11 2002/06/17 19:27:00 al Exp al $
;;
d7 7
d19 2
a20 3
;; binding, which is a list of the identifier's name (needed by
;; quote), the current value, and the binding's type (keyword or
;; variable).
d25 2
a26 2
;; variable-binding: (symbol value #f)
;; keyword-binding:  (symbol special-form #t)
d63 1
a63 3
;; [Warning: this is *very* slow].
;; The matching close parenthesis is at the end of the file.

d67 1
d75 1
a75 1
  (define (den->sym den)  (if (symbol? den) den (car den)))
d78 8
a85 6
  (define (env-add env id . den)  (lambda (i) (if (eq? id i) den (env i))))
  (define (add-var var val env)   (env-add env var (id->sym var) val #f))
  (define (add-key key val env)   (env-add env key (id->sym key) val #t))
  (define (set-val! binding val)  (set-car! (cdr binding) val))
  (define (get-val binding)       (cadr binding))
  (define (special? binding)      (caddr binding))
@


1.11
log
@Changed representation of renamed identifiers from pairs to
procedures, and made the syntax/variable distinction a part of
bindings rather than values.  Made define-syntax a builtin (distinct
from define), and made let-syntax and letrec-syntax macros that use
it.  No longer any need for a private marker.
@
text
@d3 1
a3 1
;; $Id: eiod-simple.scm,v 1.10 2002/06/12 23:15:22 al Exp al $
d11 5
a15 3
;; returns a denotation.  A denotation is either a binding, or, for
;; unbound identifiers, it is a symbol that represents the
;; identifier's original name.
d17 1
d20 2
a21 2
;; variable-binding: (identifier value #f)
;; keyword-binding:  (identifier special-form #t)
a22 1
;; identifier:       [symbol | thunk]
d31 8
a38 8
;; contain a fresh identifier, which is an eq?-unique thunk that
;; returns the old identifier's denotation in the environment of the
;; macro's definition.  When one of these "renamed" identifiers is
;; looked up in an environment that has no binding for it, the old
;; denotation is returned.  (The thunk actually returns the old
;; denotation wrapped inside a unique pair, which is immediately
;; unwrapped.  This is necessary to ensure that different thunks do
;; not compare eq?.)
d56 4
a59 2
;; so that we can feed eval to itself.  The matching close parenthesis
;; is at the end of the file.
d71 1
a71 5
  (define (den->sym den)  (if (symbol? den) den (id->sym (car den))))

  (define (empty-env id) (if (symbol? id) id (old-den id)))
  (define (add-binding binding env)
    (lambda (id) (if (eq? id (car binding)) binding (env id))))
d73 4
a76 2
  (define (add-var var val env)   (add-binding (list var val #f) env))
  (define (add-key key val env)   (add-binding (list key val #t) env))
d80 1
d313 1
a313 1
	    ((_ test . tests) (if test (and . tests)))))
d505 1
d525 6
@


1.10
log
@Added MACRO special form, implementing an explicit-renaming macro
system.  Moved syntax-rules to null-environment.  Comments now cover
all the bindings in the base environment.  Comments now use the term
"denotation" per "Macros That Work".
@
text
@d3 1
a3 1
;; $Id$
d10 27
a36 26
;; An environment is a procedure that takes an identifier and returns
;; a denotation.  A denotation is either a binding, or, for unbound
;; identifiers, it is a symbol that represents the identifier's
;; original name.  A binding is a mutable pair of an identifier and
;; its value.

;; denotation:  [symbol | binding]
;; binding:     (identifier . [value | syntax])
;; syntax:      ([builtin | transformer] . marker)
;; identifier:  [symbol | (denotation . marker)]

;; A value is any arbitrary scheme value.  Syntaxes (special forms)
;; are stored in pairs whose cdr is the eq?-unique marker object (this
;; makes them distinguishable from ordinary pair values in a variable
;; binding).  The car is either a symbol naming a builtin, or a
;; transformer procedure that takes two arguments: a macro use and the
;; environment of the macro use.

;; When a macro template containing a literal identifier is expanded,
;; the identifier is replaced with a fresh identifier, which is a new
;; pair whose cdr is the marker object (which makes such identifiers
;; distinguishable from ordinary pairs in a source-code s-expression).
;; The fresh identifier's car is the old identifier's denotation in
;; the environment of the macro's definition.  When one of these
;; "renamed" identifiers is lookep up in an environment that has no
;; binding for it, the old denotation is returned.
d41 1
a41 1
;; The base environment contains eight syntax bindings and two
d46 1
a48 1
;;   (macro x) evaluates x to get a transformer procedure and makes a macro.
d62 81
a142 78
(define eval
  (let ()
    (define marker      (vector '*eval-marker*))
    (define (mark x)    (cons x marker))
    (define unmark      car)
    (define (marked? x) (and (pair? x) (eq? marker (cdr x))))
    (define (id? sexp)  (or (symbol? sexp) (marked? sexp)))

    (define (make-builtins-env)
      (define syntaxes '(lambda set! q def begin syntax macro get-env))
      (let ((alist `((id? . ,id?)
		     (new-id . ,mark)
		     . ,(map cons syntaxes (map mark syntaxes)))))
	(lambda (id) (or (assq id alist) (if (symbol? id) id (unmark id))))))

    (define (env-add id val env)
      (define binding (cons id val))
      (lambda (i) (if (eq? id i) binding (env i))))

    (define (xeval sexp env)
      (let eval-in-this-env ((sexp sexp))
	(cond ((id? sexp) (cdr (env sexp)))
	      ((not (pair? sexp)) sexp)
	      (else (let ((head (eval-in-this-env (car sexp)))
			  (tail (cdr sexp)))
		      (if (marked? head)
			  (case (unmark head)
			    ((get-env) env)
			    ((syntax) (car tail))
			    ((lambda) (eval-lambda tail env))
			    ((begin) (eval-begin tail env))
			    ((macro) (mark (eval-in-this-env (car tail))))
			    ((set!) (set-cdr! (env (car tail))
					      (eval-in-this-env (cadr tail))))
			    ((q) (do ((x tail (car x)))
				     ((not (pair? x)) x)))
			    (else (eval-in-this-env ((unmark head) sexp env))))
			  (apply head (map eval-in-this-env tail))))))))

    (define (eval-begin tail env)
      ;; Don't use for-each because we must tail-call the last expression.
      (do ((sexps tail (cdr sexps)))
	  ((null? (cdr sexps)) (xeval (car sexps) env))
	(xeval (car sexps) env)))

    (define (eval-lambda tail env)
      (lambda args
	(define ienv (do ((args args (cdr args))
			  (vars (car tail) (cdr vars))
			  (ienv env (env-add (car vars) (car args) ienv)))
			 ((or (null? vars) (id? vars))
			  (if (null? vars) ienv (env-add vars args ienv)))))
	(let loop ((ienv ienv) (vars '()) (inits '()) (body (cdr tail)))
	  (define (ieval sexp) (xeval sexp ienv))
	  (let ((first (car body)) (rest (cdr body)))
	    (let* ((head (and (pair? first) (not (id? first)) (car first)))
		   (head-val (and (id? head) (cdr (ienv head))))
		   (special (and (marked? head-val) (unmark head-val))))
	      (if (procedure? special)
		  (loop ienv vars inits (cons (special first ienv) rest))
		  (case special
		    ((begin) (loop ienv vars inits (append (cdr first) rest)))
		    ((def) (loop (env-add (cadr first) 'undefined ienv)
				 (cons (cadr first) vars)
				 (cons (caddr first) inits)
				 rest))
		    (else (for-each set-cdr! (map ienv vars) (map ieval inits))
			  (eval-begin body ienv)))))))))

    ;; We make a copy of the initial input to ensure that subsequent
    ;; mutation of it does not affect eval's result. [1]
    (lambda (initial-sexp env)
      (xeval (let copy ((x initial-sexp))
	       (cond ((string? x) (string-copy x))
		     ((pair? x) (cons (copy (car x)) (copy (cdr x))))
		     ((vector? x) (list->vector (copy (vector->list x))))
		     (else x)))
	     (or env (make-builtins-env))))))
a150 1
	(define (spair? x)            (and (pair? x) (not (id? x))))
d153 1
a153 1
	(define (ellipsis-pair? x)    (and (spair? x) (ellipsis? (car x))))
a182 1
		 ((id? sexp) (fail))
d188 1
a188 2
		  (let slist? ((x sexp))
		    (or (null? x) (if (spair? x) (slist? (cdr x)) (fail))))
d265 10
d310 1
a310 1
	    ((_ test . tests) (if test (and . tests) #f))))
d329 1
a329 4
		(def syntax-rules*
		     (syntax-rules** id? new-id (get-env) (syntax ...)))
		(def define-syntax def)
		((lambda ()
d331 6
a336 12
		     (macro (syntax-rules*
			      (get-env)
			      (syntax ())
			      (syntax (((_ lits . rules)
					(macro (syntax-rules*
						 (get-env)
						 (syntax lits)
						 (syntax rules)))))))))
		   ((lambda ()
		      ,@@macro-defs
		      (let ((let-syntax let) (letrec-syntax letrec))
			(get-env)))))))
d519 3
a521 1
      2))))
@


1.9
log
@Builtins now have bindings.  This makes them first-class values, so
(let-syntax ((foo quote)) (foo x)) => x

Several simplifications in null-environment.
@
text
@d3 1
d11 20
a30 18
;; a binding.  A binding is either a mutable pair of an identifier and
;; its value, or, for identifiers with no true binding, it is a symbol
;; that represents the identifier's original name.

;; binding:      [symbol | (identifier . [value | special-form])]
;; special-form: ([builtin | transformer] . marker)
;; identifier:   [symbol | (binding . marker)]

;; A value is any arbitrary scheme value.  Special forms are stored in
;; pairs whose cdr is the eq?-unique marker object (this makes them
;; distinguishable from ordinary pair values in a variable binding).
;; The car is either a symbol naming a builtin, or a transformer
;; procedure that takes two arguments: a macro use and the environment
;; of the macro use.

;; When a template containing a literal identifier is expanded, the
;; identifier is replaced with a fresh identifier, which is a new pair
;; whose cdr is the marker object (which makes such identifiers
d32 4
a35 2
;; The car is the old identifier's binding in the environment of the
;; macro's definition.
d37 1
a37 1
;; This environment and identifier model is similar to the one
d40 12
d67 1
a68 9
    (define (id? sexp)    (or (symbol? sexp) (marked? sexp)))
    (define (spair? sexp) (and (pair? sexp) (not (marked? sexp))))

    (define (ids->syms sexp)
      (cond ((id? sexp) (let loop ((x sexp)) (if (pair? x) (loop (car x)) x)))
	    ((pair? sexp) (cons (ids->syms (car sexp)) (ids->syms (cdr sexp))))
	    ((vector? sexp) (list->vector (ids->syms (vector->list sexp))))
	    (else sexp)))
    
d70 4
a73 2
      (define l '(lambda quote set! syntax-rules begin builtin-define get-env))
      (let ((alist (map cons l (map mark l))))
d83 1
a83 1
	      ((not (spair? sexp)) sexp)
d89 2
a90 1
			    ((quote) (ids->syms (car tail)))
d92 1
a92 1
			    ((lambda) (eval-lambda tail env))
d95 2
a96 1
			    ((syntax-rules) (eval-syntax-rules tail env))
d111 1
a111 1
			 ((not (spair? vars))
d113 2
a114 1
	(let loop ((ienv ienv) (defs '()) (body (cdr tail)))
d116 1
a116 1
	    (let* ((head (and (spair? first) (car first)))
d120 1
a120 1
		  (loop ienv defs (cons (special first ienv) rest))
d122 6
a127 9
		    ((begin) (loop ienv defs (append (cdr first) rest)))
		    ((builtin-define)
		     (loop (env-add (cadr first) 'undefined ienv)
			   (cons (cdr first) defs)
			   rest))
		    (else (for-each set-cdr!
				    (map ienv (map car defs))
				    (map (lambda (def) (xeval (cadr def) ienv))
					 defs))
a129 97
    (define (eval-syntax-rules mac-tail mac-env)
      (define literals (car mac-tail))
      (define rules    (cdr mac-tail))

      (define (pat-literal? id)     (memq id literals))
      (define (not-pat-literal? id) (not (pat-literal? id)))

      (define (ellipsis? x)      (and (id? x) (eq? '... (mac-env x))))
      (define (ellipsis-pair? x) (and (spair? x) (ellipsis? (car x))))

      ;; List-ids returns a list of those ids in a pattern or template
      ;; for which (pred? id) is true.  If include-scalars is false, we
      ;; only include ids that are within the scope of at least one
      ;; ellipsis.
      (define (list-ids x include-scalars pred?)
	(let collect ((x x) (inc include-scalars) (l '()))
	  (cond ((vector? x) (collect (vector->list x) inc l))
		((id? x) (if (and inc (pred? x)) (cons x l) l))
		((spair? x) (if (ellipsis-pair? (cdr x))
				(collect (car x) #t (collect (cddr x) inc l))
				(collect (car x) inc (collect (cdr x) inc l))))
		(else l))))
    
      ;; Returns #f or an alist mapping each pattern var to a part of
      ;; the input.  Ellipsis vars are mapped to lists of parts (or
      ;; lists of lists...).
      (define (match-pattern pat use env)
	(call-with-current-continuation
	 (lambda (return)
	   (define (fail) (return #f))
	   (let match ((pat (cdr pat)) (sexp (cdr use)) (bindings '()))
	     (define (continue-if condition) (if condition bindings (fail)))
	     (cond
	      ((id? pat)
	       (if (pat-literal? pat)
		   (continue-if (and (id? sexp) (eq? (mac-env pat)
						     (env sexp))))
		   (cons (cons pat sexp) bindings)))
	      ((vector? pat)
	       (or (vector? sexp) (fail))
	       (match (vector->list pat) (vector->list sexp) bindings))
	      ((not (spair? pat))
	       (continue-if (equal? pat sexp)))
	      ((ellipsis-pair? (cdr pat))
	       (or (list? sexp) (fail))
	       (append (apply map list (list-ids pat #t not-pat-literal?)
			      (map (lambda (x)
				     (map cdr (match (car pat) x '())))
				   sexp))
		       bindings))
	      ((spair? sexp)
	       (match (car pat) (car sexp)
		      (match (cdr pat) (cdr sexp) bindings)))
	      (else (fail)))))))

      (define (expand-template pat tmpl top-bindings)
	(define ellipsis-vars (list-ids (cdr pat) #f not-pat-literal?))
	(define (list-ellipsis-vars subtmpl)
	  (list-ids subtmpl #t (lambda (id) (memq id ellipsis-vars))))
	;; New-literals is an alist mapping each literal id in the
	;; template to a fresh id for inserting into the output.  It
	;; might have duplicate entries mapping an id to two different
	;; fresh ids, but that's okay because when we go to retrieve a
	;; fresh id, assq will always retrieve the first one.
	(define new-literals
	  (map (lambda (id) (cons id (mark (mac-env id))))
	       (list-ids tmpl #t (lambda (id) (not (assq id top-bindings))))))
	(let expand ((tmpl tmpl) (bindings top-bindings))
	  (let expand-part ((tmpl tmpl))
	    (cond
	     ((id? tmpl) (cdr (or (assq tmpl bindings)
				  (assq tmpl top-bindings)
				  (assq tmpl new-literals))))
	     ((vector? tmpl) (list->vector (expand-part (vector->list tmpl))))
	     ((spair? tmpl)
	      (if (ellipsis-pair? (cdr tmpl))
		  (let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
		    (append (apply map
				   (lambda vals
				     (expand (car tmpl)
					     (map cons vars-to-iterate vals)))
				   (map (lambda (var)
					  (cdr (assq var bindings)))
					vars-to-iterate))
			    (expand-part (cddr tmpl))))
		  (cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
	     (else tmpl)))))

      (mark (lambda (use env)
	      (let loop ((rules rules))
		(define rule (car rules))
		(let ((pat (car rule)) (tmpl (cadr rule)))
		  (define bindings (match-pattern pat use env))
		  (if bindings
		      (expand-template pat tmpl bindings)
		      (loop (cdr rules))))))))

d143 92
d236 6
a241 1
      '((define-syntax quasiquote
d263 1
a263 1
	     (let () (builtin-define var init) ... (let () . body)))))
d309 1
a309 1
	    ((_ var init) (builtin-define var init))))
d317 18
a334 6
      ((eval `(lambda (cons append list->vector memv delay* if*)
		((lambda (define-syntax)
		   ,@@macro-defs
		   (let ((let-syntax let) (letrec-syntax letrec))
		     (get-env)))
		 builtin-define))
d336 1
a336 1
       cons append list->vector memv delay* if*))
@


1.8
log
@Removed memoizing of macro expansions.

Added define-syntax and renamed the builtin define to builtin-define.

Posted to comp.lang.scheme again.
@
text
@d11 2
a12 2
;; its value, or, for identifiers with no non-builtin binding, it is a
;; symbol that represents the identifier's original name.
d14 10
a23 7
;; binding:    [symbol | (identifier . [value | macro])]
;; macro:      (procedure . marker)
;; identifier: [symbol | (binding . marker)]

;; A value is any arbitrary scheme value.  Macros are stored in pairs
;; whose cdr is the eq?-unique marker object.  The car is a procedure
;; of two arguments: a macro use and the environment of the macro use.
d27 4
a30 2
;; containing the marker object and the binding of the old identifier
;; in the environment of the macro.
d60 5
a64 1
    (define (empty-env id) (if (symbol? id) id (unmark id)))
d73 13
a85 16
	      (else
	       (let ((head (car sexp)) (tail (cdr sexp)))
		 (let ((binding (and (id? head) (env head))))
		   (case binding
		     ((get-env) env)
		     ((quote)   (ids->syms (car tail)))
		     ((begin)   (eval-begin tail env))
		     ((lambda)  (eval-lambda tail env))
		     ((set!)    (set-cdr! (env (car tail))
					  (eval-in-this-env (cadr tail))))
		     ((syntax-rules) (eval-syntax-rules tail env))
		     (else (let ((val (and binding (cdr binding))))
			     (if (marked? val)
				 (eval-in-this-env ((unmark val) sexp env))
				 (apply (eval-in-this-env head)
					(map eval-in-this-env tail))))))))))))
d97 1
a97 1
			  (env env (env-add (car vars) (car args) env)))
d99 1
a99 1
			  (if (null? vars) env (env-add vars args env)))))
d103 15
a117 16
		   (binding (and (id? head) (ienv head))))
	      (case binding
		((begin) (loop ienv defs (append (cdr first) rest)))
		((builtin-define) (loop (env-add (cadr first) 'undefined ienv)
					(cons first defs)
					rest))
		(else
		 (let ((val (and (pair? binding) (cdr binding))))
		   (if (marked? val)
		       (loop ienv defs (cons ((unmark val) first ienv) rest))
		       (begin
			 (for-each (lambda (var val) (set-cdr! (ienv var) val))
				   (map cadr defs)
				   (map (lambda (def) (xeval (caddr def) ienv))
					defs))
			 (eval-begin body ienv)))))))))))
d134 6
a139 10
	(let collect ((x x) (including include-scalars) (l '()))
	  (cond ((vector? x) (collect (vector->list x) including l))
		((and (id? x) including (pred? x))
		 (cons x l))
		((spair? x)
		 (if (ellipsis-pair? (cdr x))
		     (collect (car x) #t
			      (collect (cddr x) including l))
		     (collect (car x) including
			      (collect (cdr x) including l))))
d224 1
a224 1
	     (or env empty-env)))))
d245 2
a246 2
		end-clause
		. commands)
d248 1
a248 3
	       (cond end-clause
		     (else (begin #f . commands)
			   (loop (begin var . step) ...)))))))
d268 7
a274 9
	  (syntax-rules (else)
	    ((_ (x . y) . clauses)
	     (let ((key (x . y)))
	       (case key . clauses)))
	    ((_ key (else . exps))
	     (begin #f . exps))
	    ((_ key (atoms . exps) . clauses)
	     (if (memv key 'atoms) (begin . exps) (case key . clauses)))
	    ((_ key) #f)))
d294 5
d300 1
a300 3
	  (syntax-rules ()
	    ((_ a b)   (if* a (lambda () b)))
	    ((_ a b c) (if* a (lambda () b) (lambda () c)))))
d302 2
a303 2
	  (syntax-rules ()
	    ((_ x) (delay* (lambda () x)))))))
a304 1
    (define (if* a b . c) (if (null? c) (if a (b)) (if a (b) ((car c)))))
d307 1
a307 7
		(builtin-define define-syntax
		  (syntax-rules () ((_ . args) (builtin-define . args))))
		(builtin-define define
	          (syntax-rules ()
		    ((_ (var . args) . body) (define var (lambda args . body)))
		    ((_ var init) (builtin-define var init))))
		((lambda ()
d310 2
a311 1
		     (get-env)))))
d325 3
a327 4
	  ((_ env name ...)
	   ((eval '(lambda (name ...) (get-env))
		  env)
	    name ...)))))
@


1.7
log
@Added memoizing macro expansion.  Doesn't seem to be any faster in scm.
@
text
@d20 1
a20 3
;; of two arguments: the tail of the macro call (i.e. all the
;; arguments in the call, without the keyword of the call), and the
;; environment of the macro call.
d56 3
a58 3
    (define (env-add var val env)
      (define binding (cons var val))
      (lambda (id) (if (eq? id var) binding (env id))))
a59 2
    (define (apply1 combo) (apply (car combo) (cdr combo)))
    
d69 1
d73 1
a73 2
					  (eval-car (cdr tail) env)))
		     ((expanded-quote) (car tail))
d75 5
a79 22
		     (else (expand-cars! sexp env)
			   (apply1 (map eval-in-this-env sexp))))))))))

    (define (expand-macros sexp env)
      (let* ((head (and (spair? sexp) (car sexp)))
	     (binding (and (id? head) (env head))))
	(if (eq? binding 'quote)
	    (list 'expanded-quote (ids->syms (cadr sexp)))
	    (let ((val (and (pair? binding) (cdr binding))))
	      (if (marked? val)
		  (expand-macros ((unmark val) (cdr sexp) env)
				 env)
		  sexp)))))

    (define (expand-cars! l env)
      (if (pair? l)
	  (begin (set-car! l (expand-macros (car l) env))
		 (expand-cars! (cdr l) env))))

    (define (eval-car pair env)
      (set-car! pair (expand-macros (car pair) env))
      (xeval (car pair) env))
a81 1
      (expand-cars! tail env)
d94 19
a112 17
	(let loop ((ienv ienv) (defs '()) (body-pair tail))
	  (let* ((body (cdr body-pair))
		 (first (expand-macros (car body) ienv)))
	    (set-car! body first)
	    (let ((head (and (spair? first) (car first))))
	      (case (and (id? head) (ienv head))
		((begin)
		 (set-cdr! body-pair (append (cdr first) (cdr body)))
		 (loop ienv defs body-pair))
		((define) (loop (env-add (cadr first) 'undefined ienv)
				(cons first defs)
				body))
		(else (for-each (lambda (var val) (set-cdr! (ienv var) val))
				(map cadr defs)
				(map (lambda (def) (eval-car (cddr def) ienv))
				     defs))
		      (eval-begin body ienv))))))))
d144 1
a144 1
      (define (match-pattern pat tail env)
d148 1
a148 1
	   (let match ((pat (cdr pat)) (sexp tail) (bindings '()))
d153 2
a154 2
		   (continue-if (and (id? sexp)
				     (eq? (mac-env pat) (env sexp))))
d174 1
a174 1
	(define ellipsis-vars (list-ids pat #f not-pat-literal?))
d188 3
a190 7
	     ((id? tmpl)
	      (let copy ((x (cdr (or (assq tmpl bindings)
				     (assq tmpl top-bindings)
				     (assq tmpl new-literals)))))
		(cond ((spair? x) (cons (copy (car x)) (copy (cdr x))))
		      ((vector? x) (list->vector (copy (vector->list x))))
		      (else x))))
d206 1
a206 1
      (mark (lambda (tail env)
d210 1
a210 1
		  (define bindings (match-pattern pat tail env))
d218 6
a223 9
      (let ((env (or env empty-env)))
	(xeval (expand-macros
		(let copy ((x initial-sexp))
		  (cond ((string? x) (string-copy x))
			((pair? x) (cons (copy (car x)) (copy (cdr x))))
			((vector? x) (list->vector (copy (vector->list x))))
			(else x)))
		env)
	       env)))))
d229 1
a229 1
      '((define quasiquote
d241 1
a241 1
	(define do
d250 1
a250 1
	(define letrec
d253 2
a254 2
	     (let () (define var init) ... (let () . body)))))
	(define let*
d259 1
a259 1
	(define let
d268 1
a268 1
	(define case
d278 1
a278 1
	(define cond
d287 1
a287 1
	(define and
d292 1
a292 1
	(define or
d297 1
a297 1
	(define if
d301 1
a301 4
	(define delay
	  (syntax-rules ()
	    ((_ x) (delay* (lambda () x)))))
	(define define-curried
d303 1
a303 2
	    ((_ (var . args) . body) (define-curried var (lambda args . body)))
	    ((_ var init) (define var init))))))
d308 10
a317 5
		,@@macro-defs
		(let ((let-syntax let)
		      (letrec-syntax letrec)
		      (define define-curried))
		  (get-env)))
d419 2
a420 3
	    ((define define-syntax)
	     (repl (eval `(let () (define ,@@(cdr exp)) (get-env))
			 env)))
@


1.6
log
@Changed environments from alists to procedures.

Added multiple-values support to repl continuations.
@
text
@d62 2
a72 1
		     ((quote)   (ids->syms (car tail)))
d76 2
a77 1
					  (eval-in-this-env (cadr tail))))
d79 22
a100 5
		     (else (let ((val (and binding (cdr binding))))
			     (if (marked? val)
				 (eval-in-this-env ((unmark val) tail env))
				 (apply (eval-in-this-env head)
					(map eval-in-this-env tail))))))))))))
d103 1
d105 3
a107 4
      (do ((sexp1 (car tail) (car sexps))
	   (sexps (cdr tail) (cdr sexps)))
	  ((null? sexps) (xeval sexp1 env))
	(xeval sexp1 env)))
d116 17
a132 22
	(let loop ((ienv ienv) (def-tails '()) (body (cdr tail)))
	  (define (finish)
	    (for-each (lambda (var val) (set-cdr! (ienv var) val))
		      (map car def-tails)
		      (map (lambda (def-tail) (xeval (cadr def-tail) ienv))
			   def-tails))
	    (eval-begin body ienv))
	  (define rest (cdr body))
	  (let retry ((sexp (car body)))
	    (if (not (spair? sexp))
		(finish)
		(let ((head (car sexp)) (tail (cdr sexp)))
		  (let ((binding (and (id? head) (ienv head))))
		    (case binding
		      ((begin) (loop ienv def-tails (append tail rest)))
		      ((define) (loop (env-add (car tail) 'undefined ienv)
				      (cons tail def-tails)
				      rest))
		      (else (let ((val (and (pair? binding) (cdr binding))))
			      (if (marked? val)
				  (retry ((unmark val) tail ienv))
				  (finish))))))))))))
d208 7
a214 3
	     ((id? tmpl) (cdr (or (assq tmpl bindings)
				  (assq tmpl top-bindings)
				  (assq tmpl new-literals))))
d242 9
a250 6
      (xeval (let copy ((x initial-sexp))
	       (cond ((string? x) (string-copy x))
		     ((pair? x) (cons (copy (car x)) (copy (cdr x))))
		     ((vector? x) (list->vector (copy (vector->list x))))
		     (else x)))
	     (or env empty-env)))))
@


1.5
log
@Changed internal definitions to use a for-each and lookup rather than
cdring through the environment.  Now lookup is the only operation used
on environments (which facilitates, should we desire, changing
environments to be unary procedures).
@
text
@d9 4
a12 1
;; An environment is an alist:
d14 3
a16 3
;; environment:    (proper-binding ...)
;; proper-binding: (identifier . [value | macro])
;; macro:          (procedure . marker)
d19 4
a22 1
;; whose cdr is the eq?-unique marker object.
d24 4
a27 2
;; identifier: [symbol | (binding . marker)]
;; binding:    [symbol | proper-binding]
d29 2
a30 4
;; When a template containing a literal identifier is expanded, the
;; identifier is replaced with a new pair containing the marker object
;; and the binding of the literal in the environment of the macro (or
;; the plain symbol if there is no binding).
d57 4
a60 4
    (define (lookup id env)
      (or (assq id env) (if (symbol? id) id (unmark id))))

    (define (acons key val alist) (cons (cons key val) alist))
d64 1
a64 1
	(cond ((id? sexp) (cdr (lookup sexp env)))
d68 1
a68 1
		 (let ((binding (and (id? head) (lookup head env))))
d74 1
a74 1
		     ((set!)    (set-cdr! (lookup (car tail) env)
d94 1
a94 1
			  (env env (acons (car vars) (car args) env)))
d96 1
a96 1
			  (if (null? vars) env (acons vars args env)))))
d99 1
a99 1
	    (for-each (lambda (var val) (set-cdr! (lookup var ienv) val))
d109 1
a109 1
		  (let ((binding (and (id? head) (lookup head ienv))))
d112 1
a112 1
		      ((define) (loop (acons (car tail) #f ienv)
d127 1
a127 1
      (define (ellipsis? x)      (and (id? x) (eq? '... (lookup x mac-env))))
d159 3
a161 3
		   (continue-if (and (id? sexp) (eq? (lookup pat mac-env)
						     (lookup sexp env))))
		   (acons pat sexp bindings)))
d189 1
a189 1
	  (map (lambda (id) (cons id (mark (lookup id mac-env))))
d229 1
a229 1
	     env))))
d323 1
a323 1
	     '())
d347 1
a347 1
	  abs quotient remainder modulo gcd lcm ;; numerator denominator
d411 2
a412 1
;; a new binding, so if you want mutually recursive top-level
d417 1
d428 3
a430 2
	     (write (eval exp env))
	     (newline)
@


1.4
log
@Rather than store the original id and environment in a renamed id, we
now lookup the original id's binding at rename time and just store the
binding in the renamed id.

Unified id-marker and macro-marker.

Removed slist?.  The marker is now a vector stored in the cdr, so a
marked object cannot be confused with a list.
@
text
@d91 1
a91 1
	(let loop ((ienv ienv) (inits '()) (body (cdr tail)))
d93 5
a97 4
	    (define (eval-ienv init) (xeval init ienv))
	    (do ((env ienv (cdr env)) (vals (map eval-ienv inits) (cdr vals)))
		((null? vals) (eval-begin body ienv))
	      (set-cdr! (car env) (car vals))))
d105 1
a105 1
		      ((begin) (loop ienv inits (append tail rest)))
d107 1
a107 1
				      (cons (cadr tail) inits)
d417 1
a417 1
	     (repl (eval `(let () (define . ,(cdr exp)) (get-env))
@


1.3
log
@Regularized eval-lambda, eval-begin, and eval-syntax-rules
@
text
@d9 1
a9 1
;; An enivronment is an alist:
d11 3
a13 2
;; environment: ((identifier . [value | macro]) ...)
;; macro: (macro-marker . procedure)
d15 2
a16 2
;; A value is any arbitrary scheme value.  Macros are stored in lists
;; whose car is the eq?-unique macro-marker object.
d18 2
a19 1
;; identifier: symbol or (id-marker environment identifier)
d22 3
a24 2
;; environment of the transformer is added to the identifier, along
;; with the eq?-unique id-marker object.
d37 7
a43 10
    (define id-marker       (list '*id-marker*))
    (define (new-id env id) (list id-marker env id))
    (define id-env          cadr)
    (define id-prev         caddr)
    (define (id->sym id)    (if (symbol? id) id (id->sym (id-prev id))))
    (define (id? sexp)      (or (symbol? sexp)
			        (and (pair? sexp) (eq? id-marker (car sexp)))))
    (define (spair? sexp)   (and (pair? sexp) (not (id? sexp))))
    (define (slist? sexp)   (or (null? sexp)
			        (and (spair? sexp) (slist? (cdr sexp)))))
d46 2
a47 3
      (cond ((id? sexp)     (id->sym sexp))
	    ((pair? sexp)   (cons (ids->syms (car sexp))
				  (ids->syms (cdr sexp))))
d49 4
a52 1
	    (else           sexp)))
d54 1
a54 4
    (define macro-marker     (list '*macro-marker*))
    (define (new-macro proc) (cons macro-marker proc))
    (define macro-proc       cdr)
    (define (vmacro? val)    (and (pair? val) (eq? macro-marker (car val))))
d56 20
a75 1
    (define (acons key val alist) (cons (cons key val) alist))
d77 6
a82 5
    (define (lookup id env)
      (or (assq id env)
	  (if (symbol? id)
	      id
	      (lookup (id-prev id) (id-env id)))))
d109 2
a110 2
			      (if (vmacro? val)
				  (retry ((macro-proc val) tail ienv))
a112 28
    (define (eval-begin tail env)
      ;; Don't use for-each because we must tail-call the last expression.
      (do ((sexp1 (car tail) (car sexps))
	   (sexps (cdr tail) (cdr sexps)))
	  ((null? sexps) (xeval sexp1 env))
	(xeval sexp1 env)))

    (define (xeval sexp env)
      (let eval-in-this-env ((sexp sexp))
	(cond ((id? sexp) (cdr (lookup sexp env)))
	      ((not (spair? sexp)) sexp)
	      (else
	       (let ((head (car sexp)) (tail (cdr sexp)))
		 (let ((binding (and (id? head) (lookup head env))))
		   (case binding
		     ((get-env) env)
		     ((quote)   (ids->syms (car tail)))
		     ((begin)   (eval-begin tail env))
		     ((lambda)  (eval-lambda tail env))
		     ((set!)    (set-cdr! (lookup (car tail) env)
					  (eval-in-this-env (cadr tail))))
		     ((syntax-rules) (eval-syntax-rules tail env))
		     (else (let ((val (and binding (cdr binding))))
			     (if (vmacro? val)
				 (eval-in-this-env ((macro-proc val) tail env))
				 (apply (eval-in-this-env head)
					(map eval-in-this-env tail))))))))))))

d161 1
a161 1
	       (or (slist? sexp) (fail))
d182 1
a182 1
	  (map (lambda (id) (cons id (new-id mac-env id)))
d205 8
a212 8
      (new-macro (lambda (tail env)
		   (let loop ((rules rules))
		     (define rule (car rules))
		     (let ((pat (car rule)) (tmpl (cadr rule)))
		       (define bindings (match-pattern pat tail env))
		       (if bindings
			   (expand-template pat tmpl bindings)
			   (loop (cdr rules))))))))
d401 1
d413 1
a413 1
      (if (not (or (eof-object? exp) (equal? exp '#(stop))))
d415 2
a416 5
	    ((define)
	     (repl (eval `(let () ,exp (get-env))
			 env)))
	    ((define-syntax)
	     (repl (eval `(letrec-syntax (,(cdr exp)) (get-env))
@


1.2
log
@Unified let-syntax and let.
@
text
@d12 1
a12 1
;; macro: (macro-marker macro-sexp macro-env)
d52 4
a55 8
    (define macro-marker  (list '*macro-marker*))
    (define (vmacro? val) (and (pair? val) (eq? macro-marker (car val))))

    (define (new-macro mac-sexp mac-env)
      (list macro-marker mac-sexp mac-env))

    (define (apply-macro mac sexp env)
      (expand-macro sexp env (cadr mac) (caddr mac)))
d65 1
a65 30
    ;; place the elements of a list into the first n bindings of env.
    (define (mutate-frame env vals)
      (do ((env env (cdr env)) (vals vals (cdr vals)))
	  ((null? vals))
	(set-cdr! (car env) (car vals))))

    (define (eval-body body env)
      (let loop ((ienv env) (inits '()) (body body))
	(define (finish)
	  (mutate-frame ienv (map (lambda (init) (xeval init ienv))
				  inits))
	  (eval-sequence body ienv))
	(define s1 (car body))
	(define rest (cdr body))
	(if (not (and (spair? s1) (id? (car s1))))
	    (finish)
	    (let ((binding (lookup (car s1) ienv)))
	      (if (symbol? binding)
		  (case binding
		    ((begin) (loop ienv inits (append (cdr s1) rest)))
		    ((define) (loop (acons (cadr s1) #f ienv)
				    (cons (caddr s1) inits)
				    rest))
		    (else (finish)))
		  (let ((val (cdr binding)))
		    (if (vmacro? val)
			(loop ienv inits (cons (apply-macro val s1 ienv) rest))
			(finish))))))))

    (define (eval-lambda vars body env)
d67 26
a92 5
	(eval-body body (do ((args args (cdr args))
			     (vars vars (cdr vars))
			     (env env (acons (car vars) (car args) env)))
			    ((not (spair? vars))
			     (if (null? vars) env (acons vars args env)))))))
d94 1
a94 1
    (define (eval-sequence exps env)
d96 4
a99 6
      (do ((exp1 (car exps) (car exps))
	   (exps (cdr exps) (cdr exps)))
	  ((null? exps) (xeval exp1 env))
	(xeval exp1 env)))

    (define (apply1 combo) (apply (car combo) (cdr combo)))
a102 1
	(define (eval-combination) (apply1 (map eval-in-this-env sexp)))
d105 20
a124 20
	      ((id? (car sexp))
	       (let ((binding (lookup (car sexp) env)))
		 (if (symbol? binding)
		     (case binding
		       ((get-env) env)
		       ((quote)   (ids->syms (cadr sexp)))
		       ((begin)   (eval-sequence (cdr sexp) env))
		       ((lambda)  (eval-lambda (cadr sexp) (cddr sexp) env))
		       ((set!)    (set-cdr! (lookup (cadr sexp) env)
					    (xeval (caddr sexp) env)))
		       ((syntax-rules) (new-macro sexp env)))
		     (let ((val (cdr binding)))
		       (if (vmacro? val)
			   (eval-in-this-env (apply-macro val sexp env))
			   (eval-combination))))))
	      (else (eval-combination)))))

    (define (expand-macro sexp env mac-sexp mac-env)
      (define literals (cadr mac-sexp))
      (define rules    (cddr mac-sexp))
a131 3
      (define (free-id=? pat-id sexp-id)
	(eq? (lookup pat-id mac-env) (lookup sexp-id env)))

d152 1
a152 1
      (define (match-pattern pat sexp)
d156 1
a156 1
	   (let match ((pat pat) (sexp sexp) (bindings '()))
d161 2
a162 1
		   (continue-if (and (id? sexp) (free-id=? pat sexp)))
d181 1
a181 1
      (define (expand-template pat tmpl sexp top-bindings)
d214 8
a221 7
      (let loop ((rules rules))
	(define rule (car rules))
	(let ((pat (car rule)) (tmpl (cadr rule)))
	  (define bindings (match-pattern (cdr pat) (cdr sexp)))
	  (if bindings
	      (expand-template (cdr pat) tmpl (cdr sexp) bindings)
	      (loop (cdr rules))))))
d225 7
a231 8
    (define (copy x)
      (cond ((string? x) (string-copy x))
	    ((pair? x) (cons (copy (car x)) (copy (cdr x))))
	    ((vector? x) (list->vector (copy (vector->list x))))
	    (else x)))

    (lambda (sexp env)
      (xeval (copy sexp) env))))
d311 5
a315 1
	    ((_ x) (delay* (lambda () x)))))))
d321 3
a323 6
		(let ((letrec-syntax letrec)
		      (let-syntax let)
		      (define (syntax-rules ()
				((_ (var . args) . body)
				 (define var (lambda args . body)))
				((_ var init) (define var init)))))
d328 5
a332 1
    (lambda (version) (force promise))))
a333 1
 
d386 4
a389 1
      (lambda (version) (force promise)))))
d409 24
@


1.1
log
@Initial revision
@
text
@a112 11
    (define (eval-let-syntax rec? sexp env)
      (let* ((body         (cddr sexp))
	     (bindings     (cadr sexp))
	     (keywords     (map car bindings))
	     (transformers (map cadr bindings))
	     (extended-env (append (map list keywords) env))
	     (mac-env      (if rec? extended-env env)))
	(mutate-frame extended-env (map (lambda (x) (new-macro x mac-env))
					transformers))
	(eval-body body extended-env)))

d130 1
a130 2
		       ((let-syntax)    (eval-let-syntax #f sexp env))
		       ((letrec-syntax) (eval-let-syntax #t sexp env)))
d253 76
a328 76
    (define macro-bindings
      '((quasiquote
	 (syntax-rules (unquote unquote-splicing quasiquote)
	   (`,x x)
	   (`(,@@x . y) (append x `y))
	   ((_ `x . d) (cons 'quasiquote       (quasiquote (x)   d)))
	   ((_ ,x   d) (cons 'unquote          (quasiquote (x) . d)))
	   ((_ ,@@x  d) (cons 'unquote-splicing (quasiquote (x) . d)))
	   ((_ (x . y) . d)
	    (cons (quasiquote x . d) (quasiquote y . d)))
	   ((_ #(x ...) . d)
	    (list->vector (quasiquote (x ...) . d)))
	   ((_ x . d) 'x)))
	(do
	 (syntax-rules ()
	   ((_ ((var init . step) ...)
	       end-clause
	       . commands)
	    (let loop ((var init) ...)
	      (cond end-clause
		    (else (begin #f . commands)
			  (loop (begin var . step) ...)))))))
	(letrec
	 (syntax-rules ()
	   ((_ ((var init) ...) . body)
	    (let () (define var init) ... (let () . body)))))
	(let*
	 (syntax-rules ()
	   ((_ () . body) (let () . body))
	   ((_ (first . more) . body)
	    (let (first) (let* more . body)))))
	(let
	 (syntax-rules ()
	   ((_ ((var init) ...) . body)
	    ((lambda (var ...) . body)
	     init ...))
	   ((_ name ((var init) ...) . body)
	    ((letrec ((name (lambda (var ...) . body)))
	       name)
	     init ...))))
	(case
	 (syntax-rules (else)
	   ((_ (x . y) . clauses)
	    (let ((key (x . y)))
	      (case key . clauses)))
	   ((_ key (else . exps))
	    (begin #f . exps))
	   ((_ key (atoms . exps) . clauses)
	    (if (memv key 'atoms) (begin . exps) (case key . clauses)))
	   ((_ key) #f)))
	(cond
	 (syntax-rules (else =>)
	   ((_) #f)
	   ((_ (else . exps)) (begin #f . exps))
	   ((_ (x) . rest) (or x (cond . rest)))
	   ((_ (x => proc) . rest)
	    (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
	   ((_ (x . exps) . rest)
	    (if x (begin . exps) (cond . rest)))))
	(and
	 (syntax-rules ()
	   ((_) #t)
	   ((_ test) test)
	   ((_ test . tests) (if test (and . tests) #f))))
	(or
	 (syntax-rules ()
	   ((_) #f)
	   ((_ test) test)
	   ((_ test . tests) (let ((x test)) (if x x (or . tests))))))
	(if
	 (syntax-rules ()
	   ((_ a b)   (if* a (lambda () b)))
	   ((_ a b c) (if* a (lambda () b) (lambda () c)))))
	(delay
	 (syntax-rules ()
	   ((_ x) (delay* (lambda () x)))))))
d333 8
a340 9
		(letrec-syntax ,macro-bindings
		  (let-syntax
		      ((define
			 (syntax-rules ()
			   ((_ (var . args) . body)
			    (define var (lambda args . body)))
			   ((_ var init)
			    (define var init)))))
		    (get-env))))
@