1;;; SCHEME -- A Scheme interpreter evaluating a sort, written by Marc Feeley. 2 3; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 4 5(define (scheme-eval expr) 6 (let ((code (scheme-comp expr scheme-global-environment))) 7 (code #f))) 8 9(define scheme-global-environment 10 (cons '() ; environment chain 11 '())) ; macros 12 13(define (scheme-add-macro name proc) 14 (set-cdr! scheme-global-environment 15 (cons (cons name proc) (cdr scheme-global-environment))) 16 name) 17 18(define (scheme-error msg . args) 19 (fatal-error msg args)) 20 21; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 22 23(define (lst->vector l) 24 (let* ((n (length l)) 25 (v (make-vector n))) 26 (let loop ((l l) (i 0)) 27 (if (pair? l) 28 (begin 29 (vector-set! v i (car l)) 30 (loop (cdr l) (+ i 1))) 31 v)))) 32 33(define (vector->lst v) 34 (let loop ((l '()) (i (- (vector-length v) 1))) 35 (if (< i 0) 36 l 37 (loop (cons (vector-ref v i) l) (- i 1))))) 38 39; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 40 41(define scheme-syntactic-keywords 42 '(quote quasiquote unquote unquote-splicing 43 lambda if set! cond => else and or 44 case let let* letrec begin do define 45 define-macro)) 46 47; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 48 49(define (push-frame frame env) 50 (if (null? frame) 51 env 52 (cons (cons (car env) frame) (cdr env)))) 53 54(define (lookup-var name env) 55 (let loop1 ((chain (car env)) (up 0)) 56 (if (null? chain) 57 name 58 (let loop2 ((chain chain) 59 (up up) 60 (frame (cdr chain)) 61 (over 1)) 62 (cond ((null? frame) 63 (loop1 (car chain) (+ up 1))) 64 ((eq? (car frame) name) 65 (cons up over)) 66 (else 67 (loop2 chain up (cdr frame) (+ over 1)))))))) 68 69(define (macro? name env) 70 (assq name (cdr env))) 71 72(define (push-macro name proc env) 73 (cons (car env) (cons (cons name proc) (cdr env)))) 74 75(define (lookup-macro name env) 76 (cdr (assq name (cdr env)))) 77 78; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 79 80(define (variable x) 81 (if (not (symbol? x)) 82 (scheme-error "Identifier expected" x)) 83 (if (memq x scheme-syntactic-keywords) 84 (scheme-error "Variable name can not be a syntactic keyword" x))) 85 86(define (shape form n) 87 (let loop ((form form) (n n) (l form)) 88 (cond ((<= n 0)) 89 ((pair? l) 90 (loop form (- n 1) (cdr l))) 91 (else 92 (scheme-error "Ill-constructed form" form))))) 93 94; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 95 96(define (macro-expand expr env) 97 (apply (lookup-macro (car expr) env) (cdr expr))) 98 99; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 100 101(define (comp-var expr env) 102 (variable expr) 103 (gen-var-ref (lookup-var expr env))) 104 105; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 106 107(define (comp-self-eval expr env) 108 (gen-cst expr)) 109 110; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 111 112(define (comp-quote expr env) 113 (shape expr 2) 114 (gen-cst (cadr expr))) 115 116; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 117 118(define (comp-quasiquote expr env) 119 (comp-quasiquotation (cadr expr) 1 env)) 120 121(define (comp-quasiquotation form level env) 122 (cond ((= level 0) 123 (scheme-comp form env)) 124 ((pair? form) 125 (cond 126 ((eq? (car form) 'quasiquote) 127 (comp-quasiquotation-list form (+ level 1) env)) 128 ((eq? (car form) 'unquote) 129 (if (= level 1) 130 (scheme-comp (cadr form) env) 131 (comp-quasiquotation-list form (- level 1) env))) 132 ((eq? (car form) 'unquote-splicing) 133 (if (= level 1) 134 (scheme-error "Ill-placed 'unquote-splicing'" form)) 135 (comp-quasiquotation-list form (- level 1) env)) 136 (else 137 (comp-quasiquotation-list form level env)))) 138 ((vector? form) 139 (gen-vector-form 140 (comp-quasiquotation-list (vector->lst form) level env))) 141 (else 142 (gen-cst form)))) 143 144(define (comp-quasiquotation-list l level env) 145 (if (pair? l) 146 (let ((first (car l))) 147 (if (= level 1) 148 (if (unquote-splicing? first) 149 (begin 150 (shape first 2) 151 (gen-append-form (scheme-comp (cadr first) env) 152 (comp-quasiquotation (cdr l) 1 env))) 153 (gen-cons-form (comp-quasiquotation first level env) 154 (comp-quasiquotation (cdr l) level env))) 155 (gen-cons-form (comp-quasiquotation first level env) 156 (comp-quasiquotation (cdr l) level env)))) 157 (comp-quasiquotation l level env))) 158 159(define (unquote-splicing? x) 160 (if (pair? x) 161 (if (eq? (car x) 'unquote-splicing) #t #f) 162 #f)) 163 164; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 165 166(define (comp-unquote expr env) 167 (scheme-error "Ill-placed 'unquote'" expr)) 168 169; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 170 171(define (comp-unquote-splicing expr env) 172 (scheme-error "Ill-placed 'unquote-splicing'" expr)) 173 174; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 175 176(define (comp-set! expr env) 177 (shape expr 3) 178 (variable (cadr expr)) 179 (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env))) 180 181; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 182 183(define (comp-lambda expr env) 184 (shape expr 3) 185 (let ((parms (cadr expr))) 186 (let ((frame (parms->frame parms))) 187 (let ((nb-vars (length frame)) 188 (code (comp-body (cddr expr) (push-frame frame env)))) 189 (if (rest-param? parms) 190 (gen-lambda-rest nb-vars code) 191 (gen-lambda nb-vars code)))))) 192 193(define (parms->frame parms) 194 (cond ((null? parms) 195 '()) 196 ((pair? parms) 197 (let ((x (car parms))) 198 (variable x) 199 (cons x (parms->frame (cdr parms))))) 200 (else 201 (variable parms) 202 (list parms)))) 203 204(define (rest-param? parms) 205 (cond ((pair? parms) 206 (rest-param? (cdr parms))) 207 ((null? parms) 208 #f) 209 (else 210 #t))) 211 212(define (comp-body body env) 213 214 (define (letrec-defines vars vals body env) 215 (if (pair? body) 216 217 (let ((expr (car body))) 218 (cond ((not (pair? expr)) 219 (letrec-defines* vars vals body env)) 220 ((macro? (car expr) env) 221 (letrec-defines vars 222 vals 223 (cons (macro-expand expr env) (cdr body)) 224 env)) 225 (else 226 (cond 227 ((eq? (car expr) 'begin) 228 (letrec-defines vars 229 vals 230 (append (cdr expr) (cdr body)) 231 env)) 232 ((eq? (car expr) 'define) 233 (let ((x (definition-name expr))) 234 (variable x) 235 (letrec-defines (cons x vars) 236 (cons (definition-value expr) vals) 237 (cdr body) 238 env))) 239 ((eq? (car expr) 'define-macro) 240 (let ((x (definition-name expr))) 241 (letrec-defines vars 242 vals 243 (cdr body) 244 (push-macro 245 x 246 (scheme-eval (definition-value expr)) 247 env)))) 248 (else 249 (letrec-defines* vars vals body env)))))) 250 251 (scheme-error "Body must contain at least one evaluable expression"))) 252 253 (define (letrec-defines* vars vals body env) 254 (if (null? vars) 255 (comp-sequence body env) 256 (comp-letrec-aux vars vals body env))) 257 258 (letrec-defines '() '() body env)) 259 260(define (definition-name expr) 261 (shape expr 3) 262 (let ((pattern (cadr expr))) 263 (let ((name (if (pair? pattern) (car pattern) pattern))) 264 (if (not (symbol? name)) 265 (scheme-error "Identifier expected" name)) 266 name))) 267 268(define (definition-value expr) 269 (let ((pattern (cadr expr))) 270 (if (pair? pattern) 271 (cons 'lambda (cons (cdr pattern) (cddr expr))) 272 (caddr expr)))) 273 274; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 275 276(define (comp-if expr env) 277 (shape expr 3) 278 (let ((code1 (scheme-comp (cadr expr) env)) 279 (code2 (scheme-comp (caddr expr) env))) 280 (if (pair? (cdddr expr)) 281 (gen-if code1 code2 (scheme-comp (cadddr expr) env)) 282 (gen-when code1 code2)))) 283 284; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 285 286(define (comp-cond expr env) 287 (comp-cond-aux (cdr expr) env)) 288 289(define (comp-cond-aux clauses env) 290 (if (pair? clauses) 291 (let ((clause (car clauses))) 292 (shape clause 1) 293 (cond ((eq? (car clause) 'else) 294 (shape clause 2) 295 (comp-sequence (cdr clause) env)) 296 ((not (pair? (cdr clause))) 297 (gen-or (scheme-comp (car clause) env) 298 (comp-cond-aux (cdr clauses) env))) 299 ((eq? (cadr clause) '=>) 300 (shape clause 3) 301 (gen-cond-send (scheme-comp (car clause) env) 302 (scheme-comp (caddr clause) env) 303 (comp-cond-aux (cdr clauses) env))) 304 (else 305 (gen-if (scheme-comp (car clause) env) 306 (comp-sequence (cdr clause) env) 307 (comp-cond-aux (cdr clauses) env))))) 308 (gen-cst '()))) 309 310; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 311 312(define (comp-and expr env) 313 (let ((rest (cdr expr))) 314 (if (pair? rest) (comp-and-aux rest env) (gen-cst #t)))) 315 316(define (comp-and-aux l env) 317 (let ((code (scheme-comp (car l) env)) 318 (rest (cdr l))) 319 (if (pair? rest) (gen-and code (comp-and-aux rest env)) code))) 320 321; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 322 323(define (comp-or expr env) 324 (let ((rest (cdr expr))) 325 (if (pair? rest) (comp-or-aux rest env) (gen-cst #f)))) 326 327(define (comp-or-aux l env) 328 (let ((code (scheme-comp (car l) env)) 329 (rest (cdr l))) 330 (if (pair? rest) (gen-or code (comp-or-aux rest env)) code))) 331 332; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 333 334(define (comp-case expr env) 335 (shape expr 3) 336 (gen-case (scheme-comp (cadr expr) env) 337 (comp-case-aux (cddr expr) env))) 338 339(define (comp-case-aux clauses env) 340 (if (pair? clauses) 341 (let ((clause (car clauses))) 342 (shape clause 2) 343 (if (eq? (car clause) 'else) 344 (gen-case-else (comp-sequence (cdr clause) env)) 345 (gen-case-clause (car clause) 346 (comp-sequence (cdr clause) env) 347 (comp-case-aux (cdr clauses) env)))) 348 (gen-case-else (gen-cst '())))) 349 350; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 351 352(define (comp-let expr env) 353 (shape expr 3) 354 (let ((x (cadr expr))) 355 (cond ((symbol? x) 356 (shape expr 4) 357 (let ((y (caddr expr))) 358 (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr))))) 359 (scheme-comp (cons (list 'letrec (list (list x proc)) x) 360 (bindings->vals y)) 361 env)))) 362 ((pair? x) 363 (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr))) 364 (bindings->vals x)) 365 env)) 366 (else 367 (comp-body (cddr expr) env))))) 368 369(define (bindings->vars bindings) 370 (if (pair? bindings) 371 (let ((binding (car bindings))) 372 (shape binding 2) 373 (let ((x (car binding))) 374 (variable x) 375 (cons x (bindings->vars (cdr bindings))))) 376 '())) 377 378(define (bindings->vals bindings) 379 (if (pair? bindings) 380 (let ((binding (car bindings))) 381 (cons (cadr binding) (bindings->vals (cdr bindings)))) 382 '())) 383 384; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 385 386(define (comp-let* expr env) 387 (shape expr 3) 388 (let ((bindings (cadr expr))) 389 (if (pair? bindings) 390 (scheme-comp (list 'let 391 (list (car bindings)) 392 (cons 'let* (cons (cdr bindings) (cddr expr)))) 393 env) 394 (comp-body (cddr expr) env)))) 395 396; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 397 398(define (comp-letrec expr env) 399 (shape expr 3) 400 (let ((bindings (cadr expr))) 401 (comp-letrec-aux (bindings->vars bindings) 402 (bindings->vals bindings) 403 (cddr expr) 404 env))) 405 406(define (comp-letrec-aux vars vals body env) 407 (if (pair? vars) 408 (let ((new-env (push-frame vars env))) 409 (gen-letrec (comp-vals vals new-env) 410 (comp-body body new-env))) 411 (comp-body body env))) 412 413(define (comp-vals l env) 414 (if (pair? l) 415 (cons (scheme-comp (car l) env) (comp-vals (cdr l) env)) 416 '())) 417 418; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 419 420(define (comp-begin expr env) 421 (shape expr 2) 422 (comp-sequence (cdr expr) env)) 423 424(define (comp-sequence exprs env) 425 (if (pair? exprs) 426 (comp-sequence-aux exprs env) 427 (gen-cst '()))) 428 429(define (comp-sequence-aux exprs env) 430 (let ((code (scheme-comp (car exprs) env)) 431 (rest (cdr exprs))) 432 (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code))) 433 434; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 435 436(define (comp-do expr env) 437 (shape expr 3) 438 (let ((bindings (cadr expr)) 439 (exit (caddr expr))) 440 (shape exit 1) 441 (let* ((vars (bindings->vars bindings)) 442 (new-env1 (push-frame '(#f) env)) 443 (new-env2 (push-frame vars new-env1))) 444 (gen-letrec 445 (list 446 (gen-lambda 447 (length vars) 448 (gen-if 449 (scheme-comp (car exit) new-env2) 450 (comp-sequence (cdr exit) new-env2) 451 (gen-sequence 452 (comp-sequence (cdddr expr) new-env2) 453 (gen-combination 454 (gen-var-ref '(1 . 1)) 455 (comp-vals (bindings->steps bindings) new-env2)))))) 456 (gen-combination 457 (gen-var-ref '(0 . 1)) 458 (comp-vals (bindings->vals bindings) new-env1)))))) 459 460(define (bindings->steps bindings) 461 (if (pair? bindings) 462 (let ((binding (car bindings))) 463 (cons (if (pair? (cddr binding)) (caddr binding) (car binding)) 464 (bindings->steps (cdr bindings)))) 465 '())) 466 467; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 468 469(define (comp-define expr env) 470 (shape expr 3) 471 (let ((pattern (cadr expr))) 472 (let ((x (if (pair? pattern) (car pattern) pattern))) 473 (variable x) 474 (gen-sequence 475 (gen-var-set (lookup-var x env) 476 (scheme-comp (if (pair? pattern) 477 (cons 'lambda (cons (cdr pattern) (cddr expr))) 478 (caddr expr)) 479 env)) 480 (gen-cst x))))) 481 482; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 483 484(define (comp-define-macro expr env) 485 (let ((x (definition-name expr))) 486 (gen-macro x (scheme-eval (definition-value expr))))) 487 488; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 489 490(define (comp-combination expr env) 491 (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env))) 492 493;------------------------------------------------------------------------------ 494 495(define (gen-var-ref var) 496 (if (pair? var) 497 (gen-rte-ref (car var) (cdr var)) 498 (gen-glo-ref (scheme-global-var var)))) 499 500(define (gen-rte-ref up over) 501 (case up 502 ((0) (gen-slot-ref-0 over)) 503 ((1) (gen-slot-ref-1 over)) 504 (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over))))) 505 506(define (gen-slot-ref-0 i) 507 (case i 508 ((0) (lambda (rte) (vector-ref rte 0))) 509 ((1) (lambda (rte) (vector-ref rte 1))) 510 ((2) (lambda (rte) (vector-ref rte 2))) 511 ((3) (lambda (rte) (vector-ref rte 3))) 512 (else (lambda (rte) (vector-ref rte i))))) 513 514(define (gen-slot-ref-1 i) 515 (case i 516 ((0) (lambda (rte) (vector-ref (vector-ref rte 0) 0))) 517 ((1) (lambda (rte) (vector-ref (vector-ref rte 0) 1))) 518 ((2) (lambda (rte) (vector-ref (vector-ref rte 0) 2))) 519 ((3) (lambda (rte) (vector-ref (vector-ref rte 0) 3))) 520 (else (lambda (rte) (vector-ref (vector-ref rte 0) i))))) 521 522(define (gen-slot-ref-up-2 code) 523 (lambda (rte) (code (vector-ref (vector-ref rte 0) 0)))) 524 525(define (gen-glo-ref i) 526 (lambda (rte) (scheme-global-var-ref i))) 527 528; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 529 530(define (gen-cst val) 531 (case val 532 ((()) (lambda (rte) '())) 533 ((#f) (lambda (rte) #f)) 534 ((#t) (lambda (rte) #t)) 535 ((-2) (lambda (rte) -2)) 536 ((-1) (lambda (rte) -1)) 537 ((0) (lambda (rte) 0)) 538 ((1) (lambda (rte) 1)) 539 ((2) (lambda (rte) 2)) 540 (else (lambda (rte) val)))) 541 542; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 543 544(define (gen-append-form code1 code2) 545 (lambda (rte) (append (code1 rte) (code2 rte)))) 546 547(define (gen-cons-form code1 code2) 548 (lambda (rte) (cons (code1 rte) (code2 rte)))) 549 550(define (gen-vector-form code) 551 (lambda (rte) (lst->vector (code rte)))) 552 553; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 554 555(define (gen-var-set var code) 556 (if (pair? var) 557 (gen-rte-set (car var) (cdr var) code) 558 (gen-glo-set (scheme-global-var var) code))) 559 560(define (gen-rte-set up over code) 561 (case up 562 ((0) (gen-slot-set-0 over code)) 563 ((1) (gen-slot-set-1 over code)) 564 (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code)))) 565 566(define (gen-slot-set-0 i code) 567 (case i 568 ((0) (lambda (rte) (vector-set! rte 0 (code rte)))) 569 ((1) (lambda (rte) (vector-set! rte 1 (code rte)))) 570 ((2) (lambda (rte) (vector-set! rte 2 (code rte)))) 571 ((3) (lambda (rte) (vector-set! rte 3 (code rte)))) 572 (else (lambda (rte) (vector-set! rte i (code rte)))))) 573 574(define (gen-slot-set-1 i code) 575 (case i 576 ((0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte)))) 577 ((1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte)))) 578 ((2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte)))) 579 ((3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte)))) 580 (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte)))))) 581 582(define (gen-slot-set-n up i code) 583 (case i 584 ((0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte)))) 585 ((1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte)))) 586 ((2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte)))) 587 ((3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte)))) 588 (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte)))))) 589 590(define (gen-glo-set i code) 591 (lambda (rte) (scheme-global-var-set! i (code rte)))) 592 593; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 594 595(define (gen-lambda-rest nb-vars body) 596 (case nb-vars 597 ((1) (gen-lambda-1-rest body)) 598 ((2) (gen-lambda-2-rest body)) 599 ((3) (gen-lambda-3-rest body)) 600 (else (gen-lambda-n-rest nb-vars body)))) 601 602(define (gen-lambda-1-rest body) 603 (lambda (rte) 604 (lambda a 605 (body (vector rte a))))) 606 607(define (gen-lambda-2-rest body) 608 (lambda (rte) 609 (lambda (a . b) 610 (body (vector rte a b))))) 611 612(define (gen-lambda-3-rest body) 613 (lambda (rte) 614 (lambda (a b . c) 615 (body (vector rte a b c))))) 616 617(define (gen-lambda-n-rest nb-vars body) 618 (lambda (rte) 619 (lambda (a b c . d) 620 (let ((x (make-vector (+ nb-vars 1)))) 621 (vector-set! x 0 rte) 622 (vector-set! x 1 a) 623 (vector-set! x 2 b) 624 (vector-set! x 3 c) 625 (let loop ((n nb-vars) (x x) (i 4) (l d)) 626 (if (< i n) 627 (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))) 628 (vector-set! x i l))) 629 (body x))))) 630 631(define (gen-lambda nb-vars body) 632 (case nb-vars 633 ((0) (gen-lambda-0 body)) 634 ((1) (gen-lambda-1 body)) 635 ((2) (gen-lambda-2 body)) 636 ((3) (gen-lambda-3 body)) 637 (else (gen-lambda-n nb-vars body)))) 638 639(define (gen-lambda-0 body) 640 (lambda (rte) 641 (lambda () 642 (body rte)))) 643 644(define (gen-lambda-1 body) 645 (lambda (rte) 646 (lambda (a) 647 (body (vector rte a))))) 648 649(define (gen-lambda-2 body) 650 (lambda (rte) 651 (lambda (a b) 652 (body (vector rte a b))))) 653 654(define (gen-lambda-3 body) 655 (lambda (rte) 656 (lambda (a b c) 657 (body (vector rte a b c))))) 658 659(define (gen-lambda-n nb-vars body) 660 (lambda (rte) 661 (lambda (a b c . d) 662 (let ((x (make-vector (+ nb-vars 1)))) 663 (vector-set! x 0 rte) 664 (vector-set! x 1 a) 665 (vector-set! x 2 b) 666 (vector-set! x 3 c) 667 (let loop ((n nb-vars) (x x) (i 4) (l d)) 668 (if (<= i n) 669 (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))))) 670 (body x))))) 671 672; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 673 674(define (gen-sequence code1 code2) 675 (lambda (rte) (code1 rte) (code2 rte))) 676 677; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 678 679(define (gen-when code1 code2) 680 (lambda (rte) 681 (if (code1 rte) 682 (code2 rte) 683 '()))) 684 685(define (gen-if code1 code2 code3) 686 (lambda (rte) 687 (if (code1 rte) 688 (code2 rte) 689 (code3 rte)))) 690 691; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 692 693(define (gen-cond-send code1 code2 code3) 694 (lambda (rte) 695 (let ((temp (code1 rte))) 696 (if temp 697 ((code2 rte) temp) 698 (code3 rte))))) 699 700; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 701 702(define (gen-and code1 code2) 703 (lambda (rte) 704 (let ((temp (code1 rte))) 705 (if temp 706 (code2 rte) 707 temp)))) 708 709; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 710 711(define (gen-or code1 code2) 712 (lambda (rte) 713 (let ((temp (code1 rte))) 714 (if temp 715 temp 716 (code2 rte))))) 717 718; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 719 720(define (gen-case code1 code2) 721 (lambda (rte) (code2 rte (code1 rte)))) 722 723(define (gen-case-clause datums code1 code2) 724 (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key)))) 725 726(define (gen-case-else code) 727 (lambda (rte key) (code rte))) 728 729; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 730 731(define (gen-letrec vals body) 732 (let ((nb-vals (length vals))) 733 (case nb-vals 734 ((1) (gen-letrec-1 (car vals) body)) 735 ((2) (gen-letrec-2 (car vals) (cadr vals) body)) 736 ((3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body)) 737 (else (gen-letrec-n nb-vals vals body))))) 738 739(define (gen-letrec-1 val1 body) 740 (lambda (rte) 741 (let ((x (vector rte #f))) 742 (vector-set! x 1 (val1 x)) 743 (body x)))) 744 745(define (gen-letrec-2 val1 val2 body) 746 (lambda (rte) 747 (let ((x (vector rte #f #f))) 748 (vector-set! x 1 (val1 x)) 749 (vector-set! x 2 (val2 x)) 750 (body x)))) 751 752(define (gen-letrec-3 val1 val2 val3 body) 753 (lambda (rte) 754 (let ((x (vector rte #f #f #f))) 755 (vector-set! x 1 (val1 x)) 756 (vector-set! x 2 (val2 x)) 757 (vector-set! x 3 (val3 x)) 758 (body x)))) 759 760(define (gen-letrec-n nb-vals vals body) 761 (lambda (rte) 762 (let ((x (make-vector (+ nb-vals 1)))) 763 (vector-set! x 0 rte) 764 (let loop ((x x) (i 1) (l vals)) 765 (if (pair? l) 766 (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l))))) 767 (body x)))) 768 769; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 770 771(define (gen-macro name proc) 772 (lambda (rte) (scheme-add-macro name proc))) 773 774; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 775 776(define (gen-combination oper args) 777 (case (length args) 778 ((0) (gen-combination-0 oper)) 779 ((1) (gen-combination-1 oper (car args))) 780 ((2) (gen-combination-2 oper (car args) (cadr args))) 781 ((3) (gen-combination-3 oper (car args) (cadr args) (caddr args))) 782 (else (gen-combination-n oper args)))) 783 784(define (gen-combination-0 oper) 785 (lambda (rte) ((oper rte)))) 786 787(define (gen-combination-1 oper arg1) 788 (lambda (rte) ((oper rte) (arg1 rte)))) 789 790(define (gen-combination-2 oper arg1 arg2) 791 (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte)))) 792 793(define (gen-combination-3 oper arg1 arg2 arg3) 794 (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte)))) 795 796(define (gen-combination-n oper args) 797 (lambda (rte) 798 (define (evaluate l rte) 799 (if (pair? l) 800 (cons ((car l) rte) (evaluate (cdr l) rte)) 801 '())) 802 (apply (oper rte) (evaluate args rte)))) 803 804; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 805 806(define (scheme-comp expr env) 807 (cond ((symbol? expr) 808 (comp-var expr env)) 809 ((not (pair? expr)) 810 (comp-self-eval expr env)) 811 ((macro? (car expr) env) 812 (scheme-comp (macro-expand expr env) env)) 813 (else 814 (cond 815 ((eq? (car expr) 'quote) (comp-quote expr env)) 816 ((eq? (car expr) 'quasiquote) (comp-quasiquote expr env)) 817 ((eq? (car expr) 'unquote) (comp-unquote expr env)) 818 ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env)) 819 ((eq? (car expr) 'set!) (comp-set! expr env)) 820 ((eq? (car expr) 'lambda) (comp-lambda expr env)) 821 ((eq? (car expr) 'if) (comp-if expr env)) 822 ((eq? (car expr) 'cond) (comp-cond expr env)) 823 ((eq? (car expr) 'and) (comp-and expr env)) 824 ((eq? (car expr) 'or) (comp-or expr env)) 825 ((eq? (car expr) 'case) (comp-case expr env)) 826 ((eq? (car expr) 'let) (comp-let expr env)) 827 ((eq? (car expr) 'let*) (comp-let* expr env)) 828 ((eq? (car expr) 'letrec) (comp-letrec expr env)) 829 ((eq? (car expr) 'begin) (comp-begin expr env)) 830 ((eq? (car expr) 'do) (comp-do expr env)) 831 ((eq? (car expr) 'define) (comp-define expr env)) 832 ((eq? (car expr) 'define-macro) (comp-define-macro expr env)) 833 (else (comp-combination expr env)))))) 834 835; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 836 837(define (scheme-global-var name) 838 (let ((x (assq name scheme-global-variables))) 839 (if x 840 x 841 (let ((y (cons name '()))) 842 (set! scheme-global-variables (cons y scheme-global-variables)) 843 y)))) 844 845(define (scheme-global-var-ref i) 846 (cdr i)) 847 848(define (scheme-global-var-set! i val) 849 (set-cdr! i val) 850 '()) 851 852(define scheme-global-variables '()) 853 854(define (def-proc name value) 855 (scheme-global-var-set! 856 (scheme-global-var name) 857 value)) 858 859(def-proc 'not (lambda (x) (not x))) 860(def-proc 'boolean? boolean?) 861(def-proc 'eqv? eqv?) 862(def-proc 'eq? eq?) 863(def-proc 'equal? equal?) 864(def-proc 'pair? (lambda (obj) (pair? obj))) 865(def-proc 'cons (lambda (x y) (cons x y))) 866(def-proc 'car (lambda (x) (car x))) 867(def-proc 'cdr (lambda (x) (cdr x))) 868(def-proc 'set-car! set-car!) 869(def-proc 'set-cdr! set-cdr!) 870(def-proc 'caar caar) 871(def-proc 'cadr cadr) 872(def-proc 'cdar cdar) 873(def-proc 'cddr cddr) 874(def-proc 'caaar caaar) 875(def-proc 'caadr caadr) 876(def-proc 'cadar cadar) 877(def-proc 'caddr caddr) 878(def-proc 'cdaar cdaar) 879(def-proc 'cdadr cdadr) 880(def-proc 'cddar cddar) 881(def-proc 'cdddr cdddr) 882(def-proc 'caaaar caaaar) 883(def-proc 'caaadr caaadr) 884(def-proc 'caadar caadar) 885(def-proc 'caaddr caaddr) 886(def-proc 'cadaar cadaar) 887(def-proc 'cadadr cadadr) 888(def-proc 'caddar caddar) 889(def-proc 'cadddr cadddr) 890(def-proc 'cdaaar cdaaar) 891(def-proc 'cdaadr cdaadr) 892(def-proc 'cdadar cdadar) 893(def-proc 'cdaddr cdaddr) 894(def-proc 'cddaar cddaar) 895(def-proc 'cddadr cddadr) 896(def-proc 'cdddar cdddar) 897(def-proc 'cddddr cddddr) 898(def-proc 'null? (lambda (x) (null? x))) 899(def-proc 'list? list?) 900(def-proc 'list list) 901(def-proc 'length length) 902(def-proc 'append append) 903(def-proc 'reverse reverse) 904(def-proc 'list-ref list-ref) 905(def-proc 'memq memq) 906(def-proc 'memv memv) 907(def-proc 'member member) 908(def-proc 'assq assq) 909(def-proc 'assv assv) 910(def-proc 'assoc assoc) 911(def-proc 'symbol? symbol?) 912(def-proc 'symbol->string symbol->string) 913(def-proc 'string->symbol string->symbol) 914(def-proc 'number? number?) 915(def-proc 'complex? complex?) 916(def-proc 'real? real?) 917(def-proc 'rational? rational?) 918(def-proc 'integer? integer?) 919(def-proc 'exact? exact?) 920(def-proc 'inexact? inexact?) 921;(def-proc '= =) 922;(def-proc '< <) 923;(def-proc '> >) 924;(def-proc '<= <=) 925;(def-proc '>= >=) 926;(def-proc 'zero? zero?) 927;(def-proc 'positive? positive?) 928;(def-proc 'negative? negative?) 929;(def-proc 'odd? odd?) 930;(def-proc 'even? even?) 931(def-proc 'max max) 932(def-proc 'min min) 933;(def-proc '+ +) 934;(def-proc '* *) 935;(def-proc '- -) 936(def-proc '/ /) 937(def-proc 'abs abs) 938;(def-proc 'quotient quotient) 939;(def-proc 'remainder remainder) 940;(def-proc 'modulo modulo) 941(def-proc 'gcd gcd) 942(def-proc 'lcm lcm) 943;(def-proc 'numerator numerator) 944;(def-proc 'denominator denominator) 945(def-proc 'floor floor) 946(def-proc 'ceiling ceiling) 947(def-proc 'truncate truncate) 948(def-proc 'round round) 949;(def-proc 'rationalize rationalize) 950(def-proc 'exp exp) 951(def-proc 'log log) 952(def-proc 'sin sin) 953(def-proc 'cos cos) 954(def-proc 'tan tan) 955(def-proc 'asin asin) 956(def-proc 'acos acos) 957(def-proc 'atan atan) 958(def-proc 'sqrt sqrt) 959(def-proc 'expt expt) 960;(def-proc 'make-rectangular make-rectangular) 961;(def-proc 'make-polar make-polar) 962;(def-proc 'real-part real-part) 963;(def-proc 'imag-part imag-part) 964;(def-proc 'magnitude magnitude) 965;(def-proc 'angle angle) 966(def-proc 'exact->inexact exact->inexact) 967(def-proc 'inexact->exact inexact->exact) 968(def-proc 'number->string number->string) 969(def-proc 'string->number string->number) 970(def-proc 'char? char?) 971(def-proc 'char=? char=?) 972(def-proc 'char<? char<?) 973(def-proc 'char>? char>?) 974(def-proc 'char<=? char<=?) 975(def-proc 'char>=? char>=?) 976(def-proc 'char-ci=? char-ci=?) 977(def-proc 'char-ci<? char-ci<?) 978(def-proc 'char-ci>? char-ci>?) 979(def-proc 'char-ci<=? char-ci<=?) 980(def-proc 'char-ci>=? char-ci>=?) 981(def-proc 'char-alphabetic? char-alphabetic?) 982(def-proc 'char-numeric? char-numeric?) 983(def-proc 'char-whitespace? char-whitespace?) 984(def-proc 'char-lower-case? char-lower-case?) 985(def-proc 'char->integer char->integer) 986(def-proc 'integer->char integer->char) 987(def-proc 'char-upcase char-upcase) 988(def-proc 'char-downcase char-downcase) 989(def-proc 'string? string?) 990(def-proc 'make-string make-string) 991(def-proc 'string string) 992(def-proc 'string-length string-length) 993(def-proc 'string-ref string-ref) 994(def-proc 'string-set! string-set!) 995(def-proc 'string=? string=?) 996(def-proc 'string<? string<?) 997(def-proc 'string>? string>?) 998(def-proc 'string<=? string<=?) 999(def-proc 'string>=? string>=?) 1000(def-proc 'string-ci=? string-ci=?) 1001(def-proc 'string-ci<? string-ci<?) 1002(def-proc 'string-ci>? string-ci>?) 1003(def-proc 'string-ci<=? string-ci<=?) 1004(def-proc 'string-ci>=? string-ci>=?) 1005(def-proc 'substring substring) 1006(def-proc 'string-append string-append) 1007(def-proc 'vector? vector?) 1008(def-proc 'make-vector make-vector) 1009(def-proc 'vector vector) 1010(def-proc 'vector-length vector-length) 1011(def-proc 'vector-ref vector-ref) 1012(def-proc 'vector-set! vector-set!) 1013(def-proc 'procedure? procedure?) 1014(def-proc 'apply apply) 1015(def-proc 'map map) 1016(def-proc 'for-each for-each) 1017;(def-proc 'call-with-current-continuation call-with-current-continuation) 1018(def-proc 'call-with-input-file call-with-input-file) 1019(def-proc 'call-with-output-file call-with-output-file) 1020(def-proc 'input-port? input-port?) 1021(def-proc 'output-port? output-port?) 1022(def-proc 'current-input-port current-input-port) 1023(def-proc 'current-output-port current-output-port) 1024(def-proc 'open-input-file open-input-file) 1025(def-proc 'open-output-file open-output-file) 1026(def-proc 'close-input-port close-input-port) 1027(def-proc 'close-output-port close-output-port) 1028(def-proc 'eof-object? eof-object?) 1029(def-proc 'read read) 1030(def-proc 'read-char read-char) 1031(def-proc 'peek-char peek-char) 1032(def-proc 'write write) 1033(def-proc 'display display) 1034(def-proc 'newline newline) 1035(def-proc 'write-char write-char) 1036 1037; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1038 1039(define (main . args) 1040 (run-benchmark 1041 "scheme" 1042 scheme-iters 1043 (lambda (result) 1044 (equal? result 1045 '("eight" "eleven" "five" "four" "nine" "one" 1046 "seven" "six" "ten" "three" "twelve" "two"))) 1047 (lambda (expr) (lambda () (scheme-eval expr))) 1048 '(let () 1049 1050 (define (sort-list obj pred) 1051 1052 (define (loop l) 1053 (if (and (pair? l) (pair? (cdr l))) 1054 (split l '() '()) 1055 l)) 1056 1057 (define (split l one two) 1058 (if (pair? l) 1059 (split (cdr l) two (cons (car l) one)) 1060 (merge (loop one) (loop two)))) 1061 1062 (define (merge one two) 1063 (cond ((null? one) two) 1064 ((pred (car two) (car one)) 1065 (cons (car two) 1066 (merge (cdr two) one))) 1067 (else 1068 (cons (car one) 1069 (merge (cdr one) two))))) 1070 1071 (loop obj)) 1072 1073 (sort-list '("one" "two" "three" "four" "five" "six" 1074 "seven" "eight" "nine" "ten" "eleven" "twelve") 1075 string<?)))) 1076