[bpt/guile.git] / module / ice-9 / eval.scm

;;; -*- mode: scheme; coding: utf-8; -*-

;;;; Copyright (C) 2009, 2010
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

\f

;;; Commentary:

;;; Scheme eval, written in Scheme.
;;;
;;; Expressions are first expanded, by the syntax expander (i.e.
;;; psyntax), then memoized into internal forms. The evaluator itself
;;; only operates on the internal forms ("memoized expressions").
;;;
;;; Environments are represented as linked lists of the form (VAL ... .
;;; MOD). If MOD is #f, it means the environment was captured before
;;; modules were booted. If MOD is the literal value '(), we are
;;; evaluating at the top level, and so should track changes to the
;;; current module.
;;;
;;; Evaluate this in Emacs to make code indentation work right:
;;;
;;;    (put 'memoized-expression-case 'scheme-indent-function 1)
;;;

;;; Code:

\f

(eval-when (compile)
  (define-syntax capture-env
    (syntax-rules ()
      ((_ env)
       (if (null? env)
           (current-module)
           (if (not env)
               ;; the and current-module checks that modules are booted,
               ;; and thus the-root-module is defined
               (and (current-module) the-root-module)
               env)))))

  (define-syntax make-closure
    (lambda (x)
      (define *max-static-argument-count* 8)
      (define (make-formals n)
        (map (lambda (i)
               (datum->syntax
                x 
                (string->symbol
                 (string (integer->char (+ (char->integer #\a) i))))))
             (iota n)))
      (syntax-case x ()
        ((_ eval nreq rest? body env) (not (identifier? #'env))
         #'(let ((e env))
             (make-closure eval nreq rest? body e)))
        ((_ eval nreq rest? body env)
         #`(case nreq
             #,@(map (lambda (nreq)
                       (let ((formals (make-formals nreq)))
                         #`((#,nreq)
                            (if rest?
                                (lambda (#,@formals . rest)
                                  (eval body
                                        (cons* rest #,@(reverse formals)
                                               env)))
                                (lambda (#,@formals)
                                  (eval body
                                        (cons* #,@(reverse formals) env)))))))
                     (iota *max-static-argument-count*))
             (else
              #,(let ((formals (make-formals *max-static-argument-count*)))
                  #`(lambda (#,@formals . more)
                      (let lp ((new-env (cons* #,@(reverse formals) env))
                               (nreq (- nreq #,*max-static-argument-count*))
                               (args more))
                        (if (zero? nreq)
                            (eval body
                                  (if rest?
                                      (cons args new-env)
                                      (if (not (null? args))
                                          (scm-error 'wrong-number-of-args
                                                     "eval" "Wrong number of arguments"
                                                     '() #f)
                                          new-env)))
                            (if (null? args)
                                (scm-error 'wrong-number-of-args
                                           "eval" "Wrong number of arguments"
                                           '() #f)
                                (lp (cons (car args) new-env)
                                    (1- nreq)
                                    (cdr args)))))))))))))

  (define-syntax call
    (lambda (x)
      (define *max-static-call-count* 4)
      (syntax-case x ()
        ((_ eval proc nargs args env) (identifier? #'env)
         #`(case nargs
             #,@(map (lambda (nargs)
                       #`((#,nargs)
                          (proc
                           #,@(map
                               (lambda (n)
                                 (let lp ((n n) (args #'args))
                                   (if (zero? n)
                                       #`(eval (car #,args) env)
                                       (lp (1- n) #`(cdr #,args)))))
                               (iota nargs)))))
                     (iota *max-static-call-count*))
             (else
              (apply proc
                     #,@(map
                         (lambda (n)
                           (let lp ((n n) (args #'args))
                             (if (zero? n)
                                 #`(eval (car #,args) env)
                                 (lp (1- n) #`(cdr #,args)))))
                         (iota *max-static-call-count*))
                     (let lp ((exps #,(let lp ((n *max-static-call-count*)
                                               (args #'args))
                                        (if (zero? n)
                                            args
                                            (lp (1- n) #`(cdr #,args)))))
                              (args '()))
                       (if (null? exps)
                           (reverse args)
                           (lp (cdr exps)
                               (cons (eval (car exps) env) args)))))))))))

  ;; This macro could be more straightforward if the compiler had better
  ;; copy propagation. As it is we do some copy propagation by hand.
  (define-syntax mx-bind
    (lambda (x)
      (syntax-case x ()
        ((_ data () body)
         #'body)
        ((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
         #'(let ((a (car data))
                 (b (cdr data)))
             body))
        ((_ data (a . b) body) (identifier? #'a)
         #'(let ((a (car data))
                 (xb (cdr data)))
             (mx-bind xb b body)))
        ((_ data (a . b) body) 
         #'(let ((xa (car data))
                 (xb (cdr data)))
             (mx-bind xa a (mx-bind xb b body))))
        ((_ data v body) (identifier? #'v)
         #'(let ((v data))
             body)))))
  
  ;; The resulting nested if statements will be an O(n) dispatch. Once
  ;; we compile `case' effectively, this situation will improve.
  (define-syntax mx-match
    (lambda (x)
      (syntax-case x (quote)
        ((_ mx data tag)
         #'(error "what" mx))
        ((_ mx data tag (('type pat) body) c* ...)
         #`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
                               (error "not a typecode" #'type)))
               (mx-bind data pat body)
               (mx-match mx data tag c* ...))))))

  (define-syntax memoized-expression-case
    (lambda (x)
      (syntax-case x ()
        ((_ mx c ...)
         #'(let ((tag (memoized-expression-typecode mx))
                 (data (memoized-expression-data mx)))
             (mx-match mx data tag c ...)))))))


(define primitive-eval
  (let ()
    ;; The "engine". EXP is a memoized expression.
    (define (eval exp env)
      (memoized-expression-case exp
        (('begin (first . rest))
         (let lp ((first first) (rest rest))
           (if (null? rest)
               (eval first env)
               (begin
                 (eval first env)
                 (lp (car rest) (cdr rest))))))
      
        (('if (test consequent . alternate))
         (if (eval test env)
             (eval consequent env)
             (eval alternate env)))
      
        (('let (inits . body))
         (let lp ((inits inits) (new-env (capture-env env)))
           (if (null? inits)
               (eval body new-env)
               (lp (cdr inits)
                   (cons (eval (car inits) env) new-env)))))
      
        (('lambda (nreq rest? . body))
         (make-closure eval nreq rest? body (capture-env env)))
        
        (('quote x)
         x)

        (('define (name . x))
         (define! name (eval x env)))
      
        (('dynwind (in exp . out))
         (dynamic-wind (eval in env)
                       (lambda () (eval exp env))
                       (eval out env)))
        
        (('apply (f args))
         (apply (eval f env) (eval args env)))

        (('call (f nargs . args))
         (let ((proc (eval f env)))
           (call eval proc nargs args env)))
        
        (('call/cc proc)
         (call/cc (eval proc env)))

        (('call-with-values (producer . consumer))
         (call-with-values (eval producer env)
           (eval consumer env)))

        (('lexical-ref n)
         (let lp ((n n) (env env))
           (if (zero? n)
               (car env)
               (lp (1- n) (cdr env)))))
      
        (('lexical-set! (n . x))
         (let ((val (eval x env)))
           (let lp ((n n) (env env))
             (if (zero? n)
                 (set-car! env val)
                 (lp (1- n) (cdr env))))))
        
        (('toplevel-ref var-or-sym)
         (variable-ref
          (if (variable? var-or-sym)
              var-or-sym
              (let lp ((env env))
                (if (pair? env)
                    (lp (cdr env))
                    (memoize-variable-access! exp (capture-env env)))))))

        (('toplevel-set! (var-or-sym . x))
         (variable-set!
          (if (variable? var-or-sym)
              var-or-sym
              (let lp ((env env))
                (if (pair? env)
                    (lp (cdr env))
                    (memoize-variable-access! exp (capture-env env)))))
          (eval x env)))
      
        (('module-ref var-or-spec)
         (variable-ref
          (if (variable? var-or-spec)
              var-or-spec
              (memoize-variable-access! exp #f))))

        (('module-set! (x . var-or-spec))
         (variable-set!
          (if (variable? var-or-spec)
              var-or-spec
              (memoize-variable-access! exp #f))
          (eval x env)))))
  
    ;; primitive-eval
    (lambda (exp)
      "Evaluate @var{exp} in the current module."
      (eval 
       (memoize-expression ((or (module-transformer (current-module))
                                (lambda (x) x))
                            exp))
       '()))))
Commit	Line	Data
5161a3c0 AW	1	;;; -- mode: scheme; coding: utf-8; --
5161a3c0 AW	2
d69531e2	3	;;;; Copyright (C) 2009, 2010
5161a3c0 AW	4	;;;; Free Software Foundation, Inc.
	5	;;;;
	6	;;;; This library is free software; you can redistribute it and/or
	7	;;;; modify it under the terms of the GNU Lesser General Public
	8	;;;; License as published by the Free Software Foundation; either
	9	;;;; version 3 of the License, or (at your option) any later version.
	10	;;;;
	11	;;;; This library is distributed in the hope that it will be useful,
	12	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	14	;;;; Lesser General Public License for more details.
	15	;;;;
	16	;;;; You should have received a copy of the GNU Lesser General Public
	17	;;;; License along with this library; if not, write to the Free Software
	18	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	19	;;;;
	20
	21	\f
	22
	23	;;; Commentary:
	24
b2b554ef AW	25	;;; Scheme eval, written in Scheme.
	26	;;;
	27	;;; Expressions are first expanded, by the syntax expander (i.e.
	28	;;; psyntax), then memoized into internal forms. The evaluator itself
	29	;;; only operates on the internal forms ("memoized expressions").
	30	;;;
	31	;;; Environments are represented as linked lists of the form (VAL ... .
	32	;;; MOD). If MOD is #f, it means the environment was captured before
	33	;;; modules were booted. If MOD is the literal value '(), we are
	34	;;; evaluating at the top level, and so should track changes to the
	35	;;; current module.
	36	;;;
	37	;;; Evaluate this in Emacs to make code indentation work right:
	38	;;;
	39	;;; (put 'memoized-expression-case 'scheme-indent-function 1)
5161a3c0 AW	40	;;;
	41
	42	;;; Code:
	43
	44	\f
	45
5161a3c0 AW	46	(eval-when (compile)
	47	(define-syntax capture-env
	48	(syntax-rules ()
	49	((_ env)
	50	(if (null? env)
	51	(current-module)
	52	(if (not env)
b2b554ef AW	53	;; the and current-module checks that modules are booted,
b2b554ef AW	54	;; and thus the-root-module is defined
5f161164	55	(and (current-module) the-root-module)
5161a3c0 AW	56	env)))))
5161a3c0 AW	57
4abb824c AW	58	(define-syntax make-closure
4abb824c AW	59	(lambda (x)
9331f91c	60	(define max-static-argument-count 8)
4abb824c AW	61	(define (make-formals n)
	62	(map (lambda (i)
	63	(datum->syntax
	64	x
	65	(string->symbol
	66	(string (integer->char (+ (char->integer #\a) i))))))
	67	(iota n)))
	68	(syntax-case x ()
	69	((_ eval nreq rest? body env) (not (identifier? #'env))
	70	#'(let ((e env))
	71	(make-closure eval nreq rest? body e)))
	72	((_ eval nreq rest? body env)
	73	#`(case nreq
	74	#,@(map (lambda (nreq)
	75	(let ((formals (make-formals nreq)))
	76	#`((#,nreq)
	77	(if rest?
	78	(lambda (#,@formals . rest)
	79	(eval body
	80	(cons* rest #,@(reverse formals)
	81	env)))
	82	(lambda (#,@formals)
	83	(eval body
	84	(cons* #,@(reverse formals) env)))))))
	85	(iota max-static-argument-count))
	86	(else
	87	#,(let ((formals (make-formals max-static-argument-count)))
	88	#`(lambda (#,@formals . more)
	89	(let lp ((new-env (cons* #,@(reverse formals) env))
	90	(nreq (- nreq #,max-static-argument-count))
	91	(args more))
	92	(if (zero? nreq)
	93	(eval body
	94	(if rest?
	95	(cons args new-env)
	96	(if (not (null? args))
	97	(scm-error 'wrong-number-of-args
	98	"eval" "Wrong number of arguments"
	99	'() #f)
	100	new-env)))
	101	(if (null? args)
	102	(scm-error 'wrong-number-of-args
	103	"eval" "Wrong number of arguments"
	104	'() #f)
	105	(lp (cons (car args) new-env)
	106	(1- nreq)
	107	(cdr args)))))))))))))
	108
9331f91c AW	109	(define-syntax call
	110	(lambda (x)
	111	(define max-static-call-count 4)
	112	(syntax-case x ()
	113	((_ eval proc nargs args env) (identifier? #'env)
	114	#`(case nargs
	115	#,@(map (lambda (nargs)
	116	#`((#,nargs)
	117	(proc
	118	#,@(map
	119	(lambda (n)
	120	(let lp ((n n) (args #'args))
	121	(if (zero? n)
	122	#`(eval (car #,args) env)
	123	(lp (1- n) #`(cdr #,args)))))
	124	(iota nargs)))))
	125	(iota max-static-call-count))
	126	(else
	127	(apply proc
	128	#,@(map
	129	(lambda (n)
	130	(let lp ((n n) (args #'args))
	131	(if (zero? n)
	132	#`(eval (car #,args) env)
	133	(lp (1- n) #`(cdr #,args)))))
	134	(iota max-static-call-count))
	135	(let lp ((exps #,(let lp ((n max-static-call-count)
	136	(args #'args))
	137	(if (zero? n)
	138	args
	139	(lp (1- n) #`(cdr #,args)))))
	140	(args '()))
	141	(if (null? exps)
	142	(reverse args)
	143	(lp (cdr exps)
	144	(cons (eval (car exps) env) args)))))))))))
	145
b2b554ef AW	146	;; This macro could be more straightforward if the compiler had better
b2b554ef AW	147	;; copy propagation. As it is we do some copy propagation by hand.
5161a3c0 AW	148	(define-syntax mx-bind
	149	(lambda (x)
	150	(syntax-case x ()
	151	((_ data () body)
	152	#'body)
	153	((_ data (a . b) body) (and (identifier? #'a) (identifier? #'b))
	154	#'(let ((a (car data))
	155	(b (cdr data)))
	156	body))
	157	((_ data (a . b) body) (identifier? #'a)
	158	#'(let ((a (car data))
	159	(xb (cdr data)))
	160	(mx-bind xb b body)))
	161	((_ data (a . b) body)
	162	#'(let ((xa (car data))
	163	(xb (cdr data)))
	164	(mx-bind xa a (mx-bind xb b body))))
	165	((_ data v body) (identifier? #'v)
	166	#'(let ((v data))
	167	body)))))
	168
b2b554ef AW	169	;; The resulting nested if statements will be an O(n) dispatch. Once
b2b554ef AW	170	;; we compile `case' effectively, this situation will improve.
5161a3c0 AW	171	(define-syntax mx-match
	172	(lambda (x)
	173	(syntax-case x (quote)
	174	((_ mx data tag)
	175	#'(error "what" mx))
	176	((_ mx data tag (('type pat) body) c* ...)
	177	#`(if (eqv? tag #,(or (memoized-typecode (syntax->datum #'type))
	178	(error "not a typecode" #'type)))
	179	(mx-bind data pat body)
	180	(mx-match mx data tag c* ...))))))
	181
	182	(define-syntax memoized-expression-case
	183	(lambda (x)
	184	(syntax-case x ()
	185	((_ mx c ...)
	186	#'(let ((tag (memoized-expression-typecode mx))
	187	(data (memoized-expression-data mx)))
	188	(mx-match mx data tag c ...)))))))
	189
	190
	191	(define primitive-eval
	192	(let ()
b2b554ef	193	;; The "engine". EXP is a memoized expression.
5161a3c0 AW	194	(define (eval exp env)
	195	(memoized-expression-case exp
	196	(('begin (first . rest))
	197	(let lp ((first first) (rest rest))
	198	(if (null? rest)
	199	(eval first env)
	200	(begin
	201	(eval first env)
	202	(lp (car rest) (cdr rest))))))
	203
	204	(('if (test consequent . alternate))
	205	(if (eval test env)
	206	(eval consequent env)
	207	(eval alternate env)))
	208
	209	(('let (inits . body))
	210	(let lp ((inits inits) (new-env (capture-env env)))
	211	(if (null? inits)
	212	(eval body new-env)
	213	(lp (cdr inits)
	214	(cons (eval (car inits) env) new-env)))))
	215
	216	(('lambda (nreq rest? . body))
4abb824c AW	217	(make-closure eval nreq rest? body (capture-env env)))
4abb824c AW	218
5161a3c0 AW	219	(('quote x)
	220	x)
	221
	222	(('define (name . x))
	223	(define! name (eval x env)))
	224
d69531e2 AW	225	(('dynwind (in exp . out))
	226	(dynamic-wind (eval in env)
	227	(lambda () (eval exp env))
	228	(eval out env)))
	229
5161a3c0 AW	230	(('apply (f args))
	231	(apply (eval f env) (eval args env)))
	232
9331f91c	233	(('call (f nargs . args))
5161a3c0	234	(let ((proc (eval f env)))
9331f91c AW	235	(call eval proc nargs args env)))
9331f91c AW	236
5161a3c0 AW	237	(('call/cc proc)
	238	(call/cc (eval proc env)))
	239
	240	(('call-with-values (producer . consumer))
	241	(call-with-values (eval producer env)
	242	(eval consumer env)))
	243
	244	(('lexical-ref n)
	245	(let lp ((n n) (env env))
	246	(if (zero? n)
	247	(car env)
	248	(lp (1- n) (cdr env)))))
	249
	250	(('lexical-set! (n . x))
	251	(let ((val (eval x env)))
	252	(let lp ((n n) (env env))
	253	(if (zero? n)
	254	(set-car! env val)
	255	(lp (1- n) (cdr env))))))
	256
	257	(('toplevel-ref var-or-sym)
	258	(variable-ref
	259	(if (variable? var-or-sym)
	260	var-or-sym
	261	(let lp ((env env))
	262	(if (pair? env)
	263	(lp (cdr env))
	264	(memoize-variable-access! exp (capture-env env)))))))
	265
	266	(('toplevel-set! (var-or-sym . x))
	267	(variable-set!
	268	(if (variable? var-or-sym)
	269	var-or-sym
	270	(let lp ((env env))
	271	(if (pair? env)
	272	(lp (cdr env))
	273	(memoize-variable-access! exp (capture-env env)))))
	274	(eval x env)))
	275
	276	(('module-ref var-or-spec)
	277	(variable-ref
	278	(if (variable? var-or-spec)
	279	var-or-spec
	280	(memoize-variable-access! exp #f))))
	281
	282	(('module-set! (x . var-or-spec))
	283	(variable-set!
	284	(if (variable? var-or-spec)
	285	var-or-spec
	286	(memoize-variable-access! exp #f))
	287	(eval x env)))))
	288
b2b554ef	289	;; primitive-eval
5161a3c0	290	(lambda (exp)
b2b554ef	291	"Evaluate @var{exp} in the current module."
5161a3c0	292	(eval
5f161164 AW	293	(memoize-expression ((or (module-transformer (current-module))
5f161164 AW	294	(lambda (x) x))
5161a3c0 AW	295	exp))
	296	'()))))
	297