module/ice-9/eval.scm

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2
   3 ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 ;;;;
  19
  20 \f
  21
  22 ;;; Commentary:
  23
  24 ;;; Scheme eval, written in Scheme.
  25 ;;;
  26 ;;; Expressions are first expanded, by the syntax expander (i.e.
  27 ;;; psyntax), then memoized into internal forms. The evaluator itself
  28 ;;; only operates on the internal forms ("memoized expressions").
  29 ;;;
  30 ;;; Environments are represented as a chain of vectors, linked through
  31 ;;; their first elements.  The terminal element of an environment is the
  32 ;;; module that was current when the outer lexical environment was
  33 ;;; entered.
  34 ;;;
  35
  36 ;;; Code:
  37
  38 \f
  39
  40 (define (primitive-eval exp)
  41   "Evaluate @var{exp} in the current module."
  42   (define-syntax env-toplevel
  43     (syntax-rules ()
  44       ((_ env)
  45        (let lp ((e env))
  46          (if (vector? e)
  47              (lp (vector-ref e 0))
  48              e)))))
  49
  50   (define-syntax make-env
  51     (syntax-rules ()
  52       ((_ n init next)
  53        (let ((v (make-vector (1+ n) init)))
  54          (vector-set! v 0 next)
  55          v))))
  56
  57   (define-syntax make-env*
  58     (syntax-rules ()
  59       ((_ next init ...)
  60        (vector next init ...))))
  61
  62   (define-syntax env-ref
  63     (syntax-rules ()
  64       ((_ env depth width)
  65        (let lp ((e env) (d depth))
  66          (if (zero? d)
  67              (vector-ref e (1+ width))
  68              (lp (vector-ref e 0) (1- d)))))))
  69
  70   (define-syntax env-set!
  71     (syntax-rules ()
  72       ((_ env depth width val)
  73        (let lp ((e env) (d depth))
  74          (if (zero? d)
  75              (vector-set! e (1+ width) val)
  76              (lp (vector-ref e 0) (1- d)))))))
  77
  78   ;; This is a modified version of Oleg Kiselyov's "pmatch".
  79   (define-syntax-rule (match e cs ...)
  80     (let ((v e)) (expand-clauses v cs ...)))
  81
  82   (define-syntax expand-clauses
  83     (syntax-rules ()
  84       ((_ v) ((error "unreachable")))
  85       ((_ v (pat e0 e ...) cs ...)
  86        (let ((fk (lambda () (expand-clauses v cs ...))))
  87          (expand-pattern v pat (let () e0 e ...) (fk))))))
  88
  89   (define-syntax expand-pattern
  90     (syntax-rules (_ quote unquote)
  91       ((_ v _ kt kf) kt)
  92       ((_ v () kt kf) (if (null? v) kt kf))
  93       ((_ v (quote lit) kt kf)
  94        (if (equal? v (quote lit)) kt kf))
  95       ((_ v (unquote exp) kt kf)
  96        (if (equal? v exp) kt kf))
  97       ((_ v (x . y) kt kf)
  98        (if (pair? v)
  99            (let ((vx (car v)) (vy (cdr v)))
 100              (expand-pattern vx x (expand-pattern vy y kt kf) kf))
 101            kf))
 102       ((_ v #f kt kf) (if (eqv? v #f) kt kf))
 103       ((_ v var kt kf) (let ((var v)) kt))))
 104
 105   (define-syntax typecode
 106     (lambda (x)
 107       (syntax-case x ()
 108         ((_ type)
 109          (or (memoized-typecode (syntax->datum #'type))
 110              (error "not a typecode" (syntax->datum #'type)))))))
 111
 112   (define (compile-lexical-ref depth width)
 113     (lambda (env)
 114       (env-ref env depth width)))
 115
 116   (define (compile-call f nargs args)
 117     (let ((f (compile f)))
 118       (match args
 119         (() (lambda (env) ((f env))))
 120         ((a)
 121          (let ((a (compile a)))
 122            (lambda (env) ((f env) (a env)))))
 123         ((a b)
 124          (let ((a (compile a))
 125                (b (compile b)))
 126            (lambda (env) ((f env) (a env) (b env)))))
 127         ((a b c)
 128          (let ((a (compile a))
 129                (b (compile b))
 130                (c (compile c)))
 131            (lambda (env) ((f env) (a env) (b env) (c env)))))
 132         ((a b c . args)
 133          (let ((a (compile a))
 134                (b (compile b))
 135                (c (compile c))
 136                (args (let lp ((args args))
 137                        (if (null? args)
 138                            '()
 139                            (cons (compile (car args)) (lp (cdr args)))))))
 140            (lambda (env)
 141              (apply (f env) (a env) (b env) (c env)
 142                     (let lp ((args args))
 143                       (if (null? args)
 144                           '()
 145                           (cons ((car args) env) (lp (cdr args))))))))))))
 146
 147   (define (compile-box-ref box)
 148     (match box
 149       ((,(typecode resolve) . var-or-loc)
 150        (lambda (env)
 151          (cond
 152           ((variable? var-or-loc) (variable-ref var-or-loc))
 153           (else
 154            (set! var-or-loc
 155                  (%resolve-variable var-or-loc (env-toplevel env)))
 156            (variable-ref var-or-loc)))))
 157       ((,(typecode lexical-ref) depth . width)
 158        (lambda (env)
 159          (variable-ref (env-ref env depth width))))
 160       (_
 161        (let ((box (compile box)))
 162          (lambda (env)
 163            (variable-ref (box env)))))))
 164
 165   (define (compile-resolve var-or-loc)
 166     (lambda (env)
 167       (cond
 168        ((variable? var-or-loc) var-or-loc)
 169        (else
 170         (set! var-or-loc (%resolve-variable var-or-loc (env-toplevel env)))
 171         var-or-loc))))
 172
 173   (define (compile-if test consequent alternate)
 174     (let ((test (compile test))
 175           (consequent (compile consequent))
 176           (alternate (compile alternate)))
 177       (lambda (env)
 178         (if (test env) (consequent env) (alternate env)))))
 179
 180   (define (compile-quote x)
 181     (lambda (env) x))
 182
 183   (define (compile-let inits body)
 184     (let ((body (compile body))
 185           (width (vector-length inits)))
 186       (case width
 187         ((0) (lambda (env)
 188                (body (make-env* env))))
 189         ((1)
 190          (let ((a (compile (vector-ref inits 0))))
 191            (lambda (env)
 192              (body (make-env* env (a env))))))
 193         ((2)
 194          (let ((a (compile (vector-ref inits 0)))
 195                (b (compile (vector-ref inits 1))))
 196            (lambda (env)
 197              (body (make-env* env (a env) (b env))))))
 198         ((3)
 199          (let ((a (compile (vector-ref inits 0)))
 200                (b (compile (vector-ref inits 1)))
 201                (c (compile (vector-ref inits 2))))
 202            (lambda (env)
 203              (body (make-env* env (a env) (b env) (c env))))))
 204         ((4)
 205          (let ((a (compile (vector-ref inits 0)))
 206                (b (compile (vector-ref inits 1)))
 207                (c (compile (vector-ref inits 2)))
 208                (d (compile (vector-ref inits 3))))
 209            (lambda (env)
 210              (body (make-env* env (a env) (b env) (c env) (d env))))))
 211         (else
 212          (let lp ((n width)
 213                   (k (lambda (env)
 214                        (make-env width #f env))))
 215            (if (zero? n)
 216                (lambda (env)
 217                  (body (k env)))
 218                (lp (1- n)
 219                    (let ((init (compile (vector-ref inits (1- n)))))
 220                      (lambda (env)
 221                        (let* ((x (init env))
 222                               (new-env (k env)))
 223                          (env-set! new-env 0 (1- n) x)
 224                          new-env))))))))))
 225
 226   (define (compile-fixed-lambda body nreq)
 227     (case nreq
 228       ((0) (lambda (env)
 229              (lambda ()
 230                (body (make-env* env)))))
 231       ((1) (lambda (env)
 232              (lambda (a)
 233                (body (make-env* env a)))))
 234       ((2) (lambda (env)
 235              (lambda (a b)
 236                (body (make-env* env a b)))))
 237       ((3) (lambda (env)
 238              (lambda (a b c)
 239                (body (make-env* env a b c)))))
 240       ((4) (lambda (env)
 241              (lambda (a b c d)
 242                (body (make-env* env a b c d)))))
 243       ((5) (lambda (env)
 244              (lambda (a b c d e)
 245                (body (make-env* env a b c d e)))))
 246       ((6) (lambda (env)
 247              (lambda (a b c d e f)
 248                (body (make-env* env a b c d e f)))))
 249       ((7) (lambda (env)
 250              (lambda (a b c d e f g)
 251                (body (make-env* env a b c d e f g)))))
 252       (else
 253        (lambda (env)
 254          (lambda (a b c d e f g . more)
 255            (let ((env (make-env nreq #f env)))
 256              (env-set! env 0 0 a)
 257              (env-set! env 0 1 b)
 258              (env-set! env 0 2 c)
 259              (env-set! env 0 3 d)
 260              (env-set! env 0 4 e)
 261              (env-set! env 0 5 f)
 262              (env-set! env 0 6 g)
 263              (let lp ((n 7) (args more))
 264                (cond
 265                 ((= n nreq)
 266                  (unless (null? args)
 267                    (scm-error 'wrong-number-of-args
 268                               "eval" "Wrong number of arguments"
 269                               '() #f))
 270                  (body env))
 271                 ((null? args)
 272                  (scm-error 'wrong-number-of-args
 273                             "eval" "Wrong number of arguments"
 274                             '() #f))
 275                 (else
 276                  (env-set! env 0 n (car args))
 277                  (lp (1+ n) (cdr args)))))))))))
 278
 279   (define (compile-rest-lambda body nreq rest?)
 280     (case nreq
 281       ((0) (lambda (env)
 282              (lambda rest
 283                (body (make-env* env rest)))))
 284       ((1) (lambda (env)
 285              (lambda (a . rest)
 286                (body (make-env* env a rest)))))
 287       ((2) (lambda (env)
 288              (lambda (a b . rest)
 289                (body (make-env* env a b rest)))))
 290       ((3) (lambda (env)
 291              (lambda (a b c . rest)
 292                (body (make-env* env a b c rest)))))
 293       (else
 294        (lambda (env)
 295          (lambda (a b c . more)
 296            (let ((env (make-env (1+ nreq) #f env)))
 297              (env-set! env 0 0 a)
 298              (env-set! env 0 1 b)
 299              (env-set! env 0 2 c)
 300              (let lp ((n 3) (args more))
 301                (cond
 302                 ((= n nreq)
 303                  (env-set! env 0 n args)
 304                  (body env))
 305                 ((null? args)
 306                  (scm-error 'wrong-number-of-args
 307                             "eval" "Wrong number of arguments"
 308                             '() #f))
 309                 (else
 310                  (env-set! env 0 n (car args))
 311                  (lp (1+ n) (cdr args)))))))))))
 312
 313   (define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)
 314     (lambda (env)
 315       (define alt (and make-alt (make-alt env)))
 316       (lambda args
 317         (let ((nargs (length args)))
 318           (cond
 319            ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt))))
 320             (if alt
 321                 (apply alt args)
 322                 ((scm-error 'wrong-number-of-args
 323                             "eval" "Wrong number of arguments"
 324                             '() #f))))
 325            (else
 326             (let* ((nvals (+ nreq (if rest? 1 0) ninits))
 327                    (env (make-env nvals unbound env)))
 328               (define (bind-req args)
 329                 (let lp ((i 0) (args args))
 330                   (cond
 331                    ((< i nreq)
 332                     ;; Bind required arguments.
 333                     (env-set! env 0 i (car args))
 334                     (lp (1+ i) (cdr args)))
 335                    (else
 336                     (bind-opt args)))))
 337               (define (bind-opt args)
 338                 (let lp ((i nreq) (args args))
 339                   (cond
 340                    ((and (< i (+ nreq nopt)) (< i nargs))
 341                     (env-set! env 0 i (car args))
 342                     (lp (1+ i) (cdr args)))
 343                    (else
 344                     (bind-rest args)))))
 345               (define (bind-rest args)
 346                 (when rest?
 347                   (env-set! env 0 (+ nreq nopt) args))
 348                 (body env))
 349               (bind-req args))))))))
 350
 351   (define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
 352     (define allow-other-keys? (car kw))
 353     (define keywords (cdr kw))
 354     (lambda (env)
 355       (define alt (and make-alt (make-alt env)))
 356       (lambda args
 357         (define (npositional args)
 358           (let lp ((n 0) (args args))
 359             (if (or (null? args)
 360                     (and (>= n nreq) (keyword? (car args))))
 361                 n
 362                 (lp (1+ n) (cdr args)))))
 363         (let ((nargs (length args)))
 364           (cond
 365            ((or (< nargs nreq)
 366                 (and alt (not rest?) (> (npositional args) (+ nreq nopt))))
 367             (if alt
 368                 (apply alt args)
 369                 ((scm-error 'wrong-number-of-args
 370                             "eval" "Wrong number of arguments"
 371                             '() #f))))
 372            (else
 373             (let* ((nvals (+ nreq (if rest? 1 0) ninits))
 374                    (env (make-env nvals unbound env)))
 375               (define (bind-req args)
 376                 (let lp ((i 0) (args args))
 377                   (cond
 378                    ((< i nreq)
 379                     ;; Bind required arguments.
 380                     (env-set! env 0 i (car args))
 381                     (lp (1+ i) (cdr args)))
 382                    (else
 383                     (bind-opt args)))))
 384               (define (bind-opt args)
 385                 (let lp ((i nreq) (args args))
 386                   (cond
 387                    ((and (< i (+ nreq nopt)) (< i nargs)
 388                          (not (keyword? (car args))))
 389                     (env-set! env 0 i (car args))
 390                     (lp (1+ i) (cdr args)))
 391                    (else
 392                     (bind-rest args)))))
 393               (define (bind-rest args)
 394                 (when rest?
 395                   (env-set! env 0 (+ nreq nopt) args))
 396                 (bind-kw args))
 397               (define (bind-kw args)
 398                 (let lp ((args args))
 399                   (cond
 400                    ((and (pair? args) (pair? (cdr args))
 401                          (keyword? (car args)))
 402                     (let ((kw-pair (assq (car args) keywords))
 403                           (v (cadr args)))
 404                       (if kw-pair
 405                           ;; Found a known keyword; set its value.
 406                           (env-set! env 0 (cdr kw-pair) v)
 407                           ;; Unknown keyword.
 408                           (if (not allow-other-keys?)
 409                               ((scm-error
 410                                 'keyword-argument-error
 411                                 "eval" "Unrecognized keyword"
 412                                 '() (list (car args))))))
 413                       (lp (cddr args))))
 414                    ((pair? args)
 415                     (if rest?
 416                         ;; Be lenient parsing rest args.
 417                         (lp (cdr args))
 418                         ((scm-error 'keyword-argument-error
 419                                     "eval" "Invalid keyword"
 420                                     '() (list (car args))))))
 421                    (else
 422                     (body env)))))
 423               (bind-req args))))))))
 424
 425   (define (compute-arity alt nreq rest? nopt kw)
 426     (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
 427       (if (not alt)
 428           (let ((arglist (list nreq
 429                                nopt
 430                                (if kw (cdr kw) '())
 431                                (and kw (car kw))
 432                                (and rest? '_))))
 433             (values arglist nreq nopt rest?))
 434           (let* ((spec (cddr alt))
 435                  (nreq* (car spec))
 436                  (rest?* (if (null? (cdr spec)) #f (cadr spec)))
 437                  (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
 438                  (nopt* (if tail (car tail) 0))
 439                  (alt* (and tail (car (cddddr tail)))))
 440             (if (or (< nreq* nreq)
 441                     (and (= nreq* nreq)
 442                          (if rest?
 443                              (and rest?* (> nopt* nopt))
 444                              (or rest?* (> nopt* nopt)))))
 445                 (lp alt* nreq* nopt* rest?*)
 446                 (lp alt* nreq nopt rest?))))))
 447
 448   (define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt)
 449     (call-with-values
 450         (lambda ()
 451           (compute-arity alt nreq rest? nopt kw))
 452       (lambda (arglist min-nreq min-nopt min-rest?)
 453         (define make-alt
 454           (match alt
 455             (#f #f)
 456             ((body meta nreq . tail)
 457              (compile-lambda body meta nreq tail))))
 458         (define make-closure
 459           (if kw
 460               (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
 461               (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)))
 462         (lambda (env)
 463           (let ((proc (make-closure env)))
 464             (set-procedure-property! proc 'arglist arglist)
 465             (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?)
 466             proc)))))
 467
 468   (define (compile-lambda body meta nreq tail)
 469     (define (set-procedure-meta meta proc)
 470       (match meta
 471         (() proc)
 472         (((prop . val) . meta)
 473          (set-procedure-meta meta
 474                              (lambda (env)
 475                                (let ((proc (proc env)))
 476                                  (set-procedure-property! proc prop val)
 477                                  proc))))))
 478     (let ((body (compile body)))
 479       (set-procedure-meta
 480        meta
 481        (match tail
 482          (() (compile-fixed-lambda body nreq))
 483          ((rest? . tail)
 484           (match tail
 485             (() (compile-rest-lambda body nreq rest?))
 486             ((nopt kw ninits unbound alt)
 487              (compile-general-lambda body nreq rest? nopt kw
 488                                      ninits unbound alt))))))))
 489
 490   (define (compile-capture-env locs body)
 491     (let ((body (compile body)))
 492       (lambda (env)
 493         (let* ((len (vector-length locs))
 494                (new-env (make-env len #f (env-toplevel env))))
 495           (let lp ((n 0))
 496             (when (< n len)
 497               (match (vector-ref locs n)
 498                 ((depth . width)
 499                  (env-set! new-env 0 n (env-ref env depth width))))
 500               (lp (1+ n))))
 501           (body new-env)))))
 502
 503   (define (compile-seq head tail)
 504     (let ((head (compile head))
 505           (tail (compile tail)))
 506       (lambda (env)
 507         (head env)
 508         (tail env))))
 509
 510   (define (compile-box-set! box val)
 511     (let ((box (compile box))
 512           (val (compile val)))
 513       (lambda (env)
 514         (let ((val (val env)))
 515           (variable-set! (box env) val)))))
 516
 517   (define (compile-lexical-set! depth width x)
 518     (let ((x (compile x)))
 519       (lambda (env)
 520         (env-set! env depth width (x env)))))
 521
 522   (define (compile-call-with-values producer consumer)
 523     (let ((producer (compile producer))
 524           (consumer (compile consumer)))
 525       (lambda (env)
 526         (call-with-values (producer env)
 527           (consumer env)))))
 528
 529   (define (compile-apply f args)
 530     (let ((f (compile f))
 531           (args (compile args)))
 532       (lambda (env)
 533         (apply (f env) (args env)))))
 534
 535   (define (compile-capture-module x)
 536     (let ((x (compile x)))
 537       (lambda (env)
 538         (x (current-module)))))
 539
 540   (define (compile-call-with-prompt tag thunk handler)
 541     (let ((tag (compile tag))
 542           (thunk (compile thunk))
 543           (handler (compile handler)))
 544       (lambda (env)
 545         (call-with-prompt (tag env) (thunk env) (handler env)))))
 546
 547   (define (compile-call/cc proc)
 548     (let ((proc (compile proc)))
 549       (lambda (env)
 550         (call/cc (proc env)))))
 551
 552   (define (compile exp)
 553     (match exp
 554       ((,(typecode lexical-ref) depth . width)
 555        (compile-lexical-ref depth width))
 556
 557       ((,(typecode call) f nargs . args)
 558        (compile-call f nargs args))
 559
 560       ((,(typecode box-ref) . box)
 561        (compile-box-ref box))
 562
 563       ((,(typecode resolve) . var-or-loc)
 564        (compile-resolve var-or-loc))
 565
 566       ((,(typecode if) test consequent . alternate)
 567        (compile-if test consequent alternate))
 568
 569       ((,(typecode quote) . x)
 570        (compile-quote x))
 571
 572       ((,(typecode let) inits . body)
 573        (compile-let inits body))
 574
 575       ((,(typecode lambda) body meta nreq . tail)
 576        (compile-lambda body meta nreq tail))
 577
 578       ((,(typecode capture-env) locs . body)
 579        (compile-capture-env locs body))
 580
 581       ((,(typecode seq) head . tail)
 582        (compile-seq head tail))
 583
 584       ((,(typecode box-set!) box . val)
 585        (compile-box-set! box val))
 586
 587       ((,(typecode lexical-set!) (depth . width) . x)
 588        (compile-lexical-set! depth width x))
 589
 590       ((,(typecode call-with-values) producer . consumer)
 591        (compile-call-with-values producer consumer))
 592
 593       ((,(typecode apply) f args)
 594        (compile-apply f args))
 595
 596       ((,(typecode capture-module) . x)
 597        (compile-capture-module x))
 598
 599       ((,(typecode call-with-prompt) tag thunk . handler)
 600        (compile-call-with-prompt tag thunk handler))
 601
 602       ((,(typecode call/cc) . proc)
 603        (compile-call/cc proc))))
 604
 605   (let ((proc (compile
 606                (memoize-expression
 607                 (if (macroexpanded? exp)
 608                     exp
 609                     ((module-transformer (current-module)) exp)))))
 610         (env #f))
 611     (proc env)))