| 1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
| 2 | |
| 3 | ;;;; Copyright (C) 2009, 2010 |
| 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 | |
| 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) |
| 40 | ;;; |
| 41 | |
| 42 | ;;; Code: |
| 43 | |
| 44 | \f |
| 45 | |
| 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) |
| 53 | ;; the and current-module checks that modules are booted, |
| 54 | ;; and thus the-root-module is defined |
| 55 | (and (current-module) the-root-module) |
| 56 | env))))) |
| 57 | |
| 58 | (define-syntax make-closure |
| 59 | (lambda (x) |
| 60 | (define *max-static-argument-count* 8) |
| 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 | |
| 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 | |
| 146 | ;; This macro could be more straightforward if the compiler had better |
| 147 | ;; copy propagation. As it is we do some copy propagation by hand. |
| 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 | |
| 169 | ;; The resulting nested if statements will be an O(n) dispatch. Once |
| 170 | ;; we compile `case' effectively, this situation will improve. |
| 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 () |
| 193 | ;; The "engine". EXP is a memoized expression. |
| 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)) |
| 217 | (make-closure eval nreq rest? body (capture-env env))) |
| 218 | |
| 219 | (('quote x) |
| 220 | x) |
| 221 | |
| 222 | (('define (name . x)) |
| 223 | (define! name (eval x env))) |
| 224 | |
| 225 | (('dynwind (in exp . out)) |
| 226 | (dynamic-wind (eval in env) |
| 227 | (lambda () (eval exp env)) |
| 228 | (eval out env))) |
| 229 | |
| 230 | (('apply (f args)) |
| 231 | (apply (eval f env) (eval args env))) |
| 232 | |
| 233 | (('call (f nargs . args)) |
| 234 | (let ((proc (eval f env))) |
| 235 | (call eval proc nargs args env))) |
| 236 | |
| 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 | |
| 289 | ;; primitive-eval |
| 290 | (lambda (exp) |
| 291 | "Evaluate @var{exp} in the current module." |
| 292 | (eval |
| 293 | (memoize-expression ((or (module-transformer (current-module)) |
| 294 | (lambda (x) x)) |
| 295 | exp)) |
| 296 | '())))) |
| 297 | |