git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_const.scheme

   1 ;
   2 ; Copyright © 2016 Keith Packard <keithp@keithp.com>
   3 ;
   4 ; This program is free software; you can redistribute it and/or modify
   5 ; it under the terms of the GNU General Public License as published by
   6 ; the Free Software Foundation, either version 2 of the License, or
   7 ; (at your option) any later version.
   8 ;
   9 ; This program is distributed in the hope that it will be useful, but
  10 ; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ; General Public License for more details.
  13 ;
  14 ; Lisp code placed in ROM
  15
  16 (def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit)))))
  17
  18                                         ; return a list containing all of the arguments
  19 (def (quote list) (lambda l l))
  20
  21 (def (quote def!)
  22      (macro (name value)
  23             (list
  24              def
  25              (list quote name)
  26              value)
  27             )
  28      )
  29
  30 (begin
  31  (def! append
  32    (lambda args
  33           (def! append-list
  34             (lambda (a b)
  35               (cond ((null? a) b)
  36                     (else (cons (car a) (append-list (cdr a) b)))
  37                     )
  38               )
  39             )
  40
  41           (def! append-lists
  42             (lambda (lists)
  43               (cond ((null? lists) lists)
  44                     ((null? (cdr lists)) (car lists))
  45                     (else (append-list (car lists) (append-lists (cdr lists))))
  46                     )
  47               )
  48             )
  49           (append-lists args)
  50           )
  51    )
  52  'append)
  53
  54 (append '(a b c) '(d e f) '(g h i))
  55
  56                                         ; boolean operators
  57
  58 (begin
  59  (def! or
  60    (macro l
  61           (def! _or
  62             (lambda (l)
  63               (cond ((null? l) #f)
  64                     ((null? (cdr l))
  65                      (car l))
  66                     (else
  67                      (list
  68                       cond
  69                       (list
  70                        (car l))
  71                       (list
  72                        'else
  73                        (_or (cdr l))
  74                        )
  75                       )
  76                      )
  77                     )
  78               )
  79             )
  80           (_or l)))
  81  'or)
  82
  83                                         ; execute to resolve macros
  84
  85 (_?_ (or #f #t) #t)
  86
  87 (begin
  88  (def! and
  89    (macro l
  90           (def! _and
  91             (lambda (l)
  92               (cond ((null? l) #t)
  93                     ((null? (cdr l))
  94                      (car l))
  95                     (else
  96                      (list
  97                       cond
  98                       (list
  99                        (car l)
 100                        (_and (cdr l))
 101                        )
 102                       )
 103                      )
 104                     )
 105               )
 106             )
 107           (_and l)
 108           )
 109    )
 110  'and)
 111
 112                                         ; execute to resolve macros
 113
 114 (_?_ (and #t #f) #f)
 115
 116                                         ; recursive equality
 117
 118 (begin
 119   (def! equal?
 120     (lambda (a b)
 121       (cond ((eq? a b) #t)
 122             ((and (pair? a) (pair? b))
 123              (and (equal? (car a) (car b))
 124                   (equal? (cdr a) (cdr b)))
 125              )
 126             ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
 127              ((lambda (i l)
 128                 (while (and (< i l)
 129                             (equal? (vector-ref a i)
 130                                     (vector-ref b i)))
 131                        (set! i (+ i 1)))
 132                 (eq? i l)
 133                 )
 134               0
 135               (vector-length a)
 136               )
 137              )
 138             (else #f)
 139             )
 140       )
 141     )
 142   'equal?
 143   )
 144
 145 (_?_ (equal? '(a b c) '(a b c)) #t)
 146 (_?_ (equal? '(a b c) '(a b b)) #f)
 147 (_?_ (equal? #(1 2 3) #(1 2 3)) #t)
 148 (_?_ (equal? #(1 2 3) #(4 5 6)) #f)
 149
 150 (def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit)))))
 151
 152 (begin
 153  (def! quasiquote
 154    (macro (x)
 155           (def! constant?
 156                                         ; A constant value is either a pair starting with quote,
 157                                         ; or anything which is neither a pair nor a symbol
 158
 159             (lambda (exp)
 160               (cond ((pair? exp)
 161                      (eq? (car exp) 'quote)
 162                      )
 163                     (else
 164                      (not (symbol? exp))
 165                      )
 166                     )
 167               )
 168             )
 169           (def! combine-skeletons
 170             (lambda (left right exp)
 171               (cond
 172                ((and (constant? left) (constant? right))
 173                 (cond ((and (eqv? (eval left) (car exp))
 174                             (eqv? (eval right) (cdr exp)))
 175                        (list 'quote exp)
 176                        )
 177                       (else
 178                        (list 'quote (cons (eval left) (eval right)))
 179                        )
 180                       )
 181                 )
 182                ((null? right)
 183                 (list 'list left)
 184                 )
 185                ((and (pair? right) (eq? (car right) 'list))
 186                 (cons 'list (cons left (cdr right)))
 187                 )
 188                (else
 189                 (list 'cons left right)
 190                 )
 191                )
 192               )
 193             )
 194
 195           (def! expand-quasiquote
 196             (lambda (exp nesting)
 197               (cond
 198
 199                                         ; non cons -- constants
 200                                         ; themselves, others are
 201                                         ; quoted
 202
 203                ((not (pair? exp))
 204                 (cond ((constant? exp)
 205                        exp
 206                        )
 207                       (else
 208                        (list 'quote exp)
 209                        )
 210                       )
 211                 )
 212
 213                                         ; check for an unquote exp and
 214                                         ; add the param unquoted
 215
 216                ((and (eq? (car exp) 'unquote) (= (length exp) 2))
 217                 (cond ((= nesting 0)
 218                        (car (cdr exp))
 219                        )
 220                       (else
 221                        (combine-skeletons ''unquote
 222                                           (expand-quasiquote (cdr exp) (- nesting 1))
 223                                           exp))
 224                       )
 225                 )
 226
 227                                         ; nested quasi-quote --
 228                                         ; construct the right
 229                                         ; expression
 230
 231                ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
 232                 (combine-skeletons ''quasiquote
 233                                    (expand-quasiquote (cdr exp) (+ nesting 1))
 234                                    exp))
 235
 236                                         ; check for an
 237                                         ; unquote-splicing member,
 238                                         ; compute the expansion of the
 239                                         ; value and append the rest of
 240                                         ; the quasiquote result to it
 241
 242                ((and (pair? (car exp))
 243                      (eq? (car (car exp)) 'unquote-splicing)
 244                      (= (length (car exp)) 2))
 245                 (cond ((= nesting 0)
 246                        (list 'append (car (cdr (car exp)))
 247                              (expand-quasiquote (cdr exp) nesting))
 248                        )
 249                       (else
 250                        (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
 251                                           (expand-quasiquote (cdr exp) nesting)
 252                                           exp))
 253                       )
 254                 )
 255
 256                                         ; for other lists, just glue
 257                                         ; the expansion of the first
 258                                         ; element to the expansion of
 259                                         ; the rest of the list
 260
 261                (else (combine-skeletons (expand-quasiquote (car exp) nesting)
 262                                         (expand-quasiquote (cdr exp) nesting)
 263                                         exp)
 264                      )
 265                )
 266               )
 267             )
 268           (def! result (expand-quasiquote x 0))
 269           result
 270           )
 271    )
 272  'quasiquote)
 273
 274                                         ;
 275                                         ; Define a variable without returning the value
 276                                         ; Useful when defining functions to avoid
 277                                         ; having lots of output generated.
 278                                         ;
 279                                         ; Also accepts the alternate
 280                                         ; form for defining lambdas of
 281                                         ; (define (name x y z) sexprs ...)
 282                                         ;
 283
 284 (begin
 285  (def! define
 286    (macro (first . rest)
 287                                         ; check for alternate lambda definition form
 288
 289           (cond ((pair? first)
 290                  (set! rest
 291                        (append
 292                         (list
 293                          'lambda
 294                          (cdr first))
 295                         rest))
 296                  (set! first (car first))
 297                  )
 298                 (else
 299                  (set! rest (car rest))
 300                  )
 301                 )
 302           (def! result `(,begin
 303                          (,def (,quote ,first) ,rest)
 304                          (,quote ,first))
 305             )
 306           result
 307           )
 308    )
 309  'define
 310  )
 311
 312                                         ; basic list accessors
 313
 314 (define (caar l) (car (car l)))
 315
 316 (_??_ (caar '((1 2 3) (4 5 6))) 1)
 317
 318 (define (cadr l) (car (cdr l)))
 319
 320 (_??_ (cadr '(1 2 3 4 5 6)) 2)
 321
 322 (define (cdar l) (cdr (car l)))
 323
 324 (_??_ (cdar '((1 2) (3 4))) '(2))
 325
 326 (define (cddr l) (cdr (cdr l)))
 327
 328 (_??_ (cddr '(1 2 3)) '(3))
 329
 330 (define (caddr l) (car (cdr (cdr l))))
 331
 332 (_??_ (caddr '(1 2 3 4)) 3)
 333
 334                                         ; (if <condition> <if-true>)
 335                                         ; (if <condition> <if-true> <if-false)
 336
 337 (define if
 338   (macro (test . args)
 339          (cond ((null? (cdr args))
 340                 `(cond (,test ,(car args)))
 341                 )
 342                (else
 343                 `(cond (,test ,(car args))
 344                        (else ,(cadr args)))
 345                 )
 346                )
 347          )
 348   )
 349
 350 (_??_ (if (> 3 2) 'yes) 'yes)
 351 (_??_ (if (> 3 2) 'yes 'no) 'yes)
 352 (_??_ (if (> 2 3) 'no 'yes) 'yes)
 353 (_??_ (if (> 2 3) 'no) #f)
 354
 355                                         ; simple math operators
 356
 357 (define zero? (macro (value) `(eq? ,value 0)))
 358
 359 (_??_ (zero? 1) #f)
 360 (_??_ (zero? 0) #t)
 361 (_??_ (zero? "hello") #f)
 362
 363 (define positive? (macro (value) `(> ,value 0)))
 364
 365 (_??_ (positive? 12) #t)
 366 (_??_ (positive? -12) #f)
 367
 368 (define negative? (macro (value) `(< ,value 0)))
 369
 370 (_??_ (negative? 12) #f)
 371 (_??_ (negative? -12) #t)
 372
 373 (define (abs x) (if (>= x 0) x (- x)))
 374
 375 (_??_ (abs 12) 12)
 376 (_??_ (abs -12) 12)
 377
 378 (define max (lambda (first . rest)
 379                    (while (not (null? rest))
 380                      (cond ((< first (car rest))
 381                             (set! first (car rest)))
 382                            )
 383                      (set! rest (cdr rest))
 384                      )
 385                    first)
 386   )
 387
 388 (_??_ (max 1 2 3) 3)
 389 (_??_ (max 3 2 1) 3)
 390
 391 (define min (lambda (first . rest)
 392                    (while (not (null? rest))
 393                      (cond ((> first (car rest))
 394                             (set! first (car rest)))
 395                            )
 396                      (set! rest (cdr rest))
 397                      )
 398                    first)
 399   )
 400
 401 (_??_ (min 1 2 3) 1)
 402 (_??_ (min 3 2 1) 1)
 403
 404 (define (even? x) (zero? (% x 2)))
 405
 406 (_??_ (even? 2) #t)
 407 (_??_ (even? -2) #t)
 408 (_??_ (even? 3) #f)
 409 (_??_ (even? -1) #f)
 410
 411 (define (odd? x) (not (even? x)))
 412
 413 (_??_ (odd? 2) #f)
 414 (_??_ (odd? -2) #f)
 415 (_??_ (odd? 3) #t)
 416 (_??_ (odd? -1) #t)
 417
 418 (_??_ (list-tail '(1 2 3 . 4) 3) 4)
 419
 420 (define (list-ref x k)
 421   (car (list-tail x k))
 422   )
 423
 424 (_??_ (list-ref '(1 2 3 4) 3) 4)
 425
 426 (define (list-set! x k v)
 427   (set-car! (list-tail x k) v)
 428   x)
 429
 430 (list-set! (list 1 2 3) 1 4)
 431
 432                                         ; define a set of local
 433                                         ; variables all at once and
 434                                         ; then evaluate a list of
 435                                         ; sexprs
 436                                         ;
 437                                         ; (let (var-defines) sexprs)
 438                                         ;
 439                                         ; where var-defines are either
 440                                         ;
 441                                         ; (name value)
 442                                         ;
 443                                         ; or
 444                                         ;
 445                                         ; (name)
 446                                         ;
 447                                         ; e.g.
 448                                         ;
 449                                         ; (let ((x 1) (y)) (set! y (+ x 1)) y)
 450
 451 (define let
 452   (macro (vars . exprs)
 453          (define (make-names vars)
 454            (cond ((not (null? vars))
 455                   (cons (car (car vars))
 456                         (make-names (cdr vars))))
 457                  (else ())
 458                  )
 459            )
 460
 461                                         ; the parameters to the lambda is a list
 462                                         ; of nils of the right length
 463
 464          (define (make-vals vars)
 465            (cond ((not (null? vars))
 466                   (cons (cond ((null? (cdr (car vars))) ())
 467                               (else
 468                                (car (cdr (car vars))))
 469                               )
 470                         (make-vals (cdr vars))))
 471                  (else ())
 472                  )
 473            )
 474                                         ; prepend the set operations
 475                                         ; to the expressions
 476
 477                                         ; build the lambda.
 478
 479          `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
 480          )
 481      )
 482
 483
 484 (_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3)
 485
 486                                         ; define a set of local
 487                                         ; variables one at a time and
 488                                         ; then evaluate a list of
 489                                         ; sexprs
 490                                         ;
 491                                         ; (let* (var-defines) sexprs)
 492                                         ;
 493                                         ; where var-defines are either
 494                                         ;
 495                                         ; (name value)
 496                                         ;
 497                                         ; or
 498                                         ;
 499                                         ; (name)
 500                                         ;
 501                                         ; e.g.
 502                                         ;
 503                                         ; (let* ((x 1) (y)) (set! y (+ x 1)) y)
 504
 505 (define let*
 506   (macro (vars . exprs)
 507
 508                                         ;
 509                                         ; make the list of names in the let
 510                                         ;
 511
 512          (define (make-names vars)
 513            (cond ((not (null? vars))
 514                   (cons (car (car vars))
 515                         (make-names (cdr vars))))
 516                  (else ())
 517                  )
 518            )
 519
 520                                         ; the set of expressions is
 521                                         ; the list of set expressions
 522                                         ; pre-pended to the
 523                                         ; expressions to evaluate
 524
 525          (define (make-exprs vars exprs)
 526            (cond ((null? vars) exprs)
 527                  (else
 528                   (cons
 529                    (list set
 530                          (list quote
 531                                (car (car vars))
 532                                )
 533                          (cond ((null? (cdr (car vars))) ())
 534                                (else (cadr (car vars))))
 535                          )
 536                    (make-exprs (cdr vars) exprs)
 537                    )
 538                   )
 539                  )
 540            )
 541
 542                                         ; the parameters to the lambda is a list
 543                                         ; of nils of the right length
 544
 545          (define (make-nils vars)
 546            (cond ((null? vars) ())
 547                  (else (cons () (make-nils (cdr vars))))
 548                  )
 549            )
 550                                         ; build the lambda.
 551
 552          `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars))
 553          )
 554      )
 555
 556 (_??_ (let* ((x 1) (y x)) (+ x y)) 2)
 557
 558 (define when (macro (test . l) `(cond (,test ,@l))))
 559
 560 (_??_ (when #t (+ 1 2)) 3)
 561 (_??_ (when #f (+ 1 2)) #f)
 562
 563 (define unless (macro (test . l) `(cond ((not ,test) ,@l))))
 564
 565 (_??_ (unless #f (+ 2 3)) 5)
 566 (_??_ (unless #t (+ 2 3)) #f)
 567
 568 (define (reverse list)
 569   (define (_r old new)
 570     (if (null? old)
 571         new
 572         (_r (cdr old) (cons (car old) new))
 573         )
 574     )
 575   (_r list ())
 576   )
 577
 578 (_??_ (reverse '(1 2 3)) '(3 2 1))
 579
 580 (define make-list
 581   (lambda (a . b)
 582     (define (_m a x)
 583       (if (zero? a)
 584           x
 585           (_m (- a 1) (cons b x))
 586           )
 587       )
 588     (if (null? b)
 589         (set! b #f)
 590         (set! b (car b))
 591         )
 592     (_m a '())
 593     )
 594   )
 595
 596 (_??_ (make-list 10 'a) '(a a a a a a a a a a))
 597
 598 (_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f))
 599
 600 (define member (lambda (obj list . test?)
 601                       (cond ((null? list)
 602                              #f
 603                              )
 604                             (else
 605                              (if (null? test?) (set! test? equal?) (set! test? (car test?)))
 606                              (if (test? obj (car list))
 607                                  list
 608                                (member obj (cdr list) test?))
 609                              )
 610                             )
 611                       )
 612   )
 613
 614 (_??_ (member '(2) '((1) (2) (3)))  '((2) (3)))
 615
 616 (_??_ (member '(4) '((1) (2) (3))) #f)
 617
 618 (define (memq obj list) (member obj list eq?))
 619
 620 (_??_ (memq 2 '(1 2 3)) '(2 3))
 621
 622 (_??_ (memq 4 '(1 2 3)) #f)
 623
 624 (_??_ (memq '(2) '((1) (2) (3))) #f)
 625
 626 (define (memv obj list) (member obj list eqv?))
 627
 628 (_??_ (memv 2 '(1 2 3)) '(2 3))
 629
 630 (_??_ (memv 4 '(1 2 3)) #f)
 631
 632 (_??_ (memv '(2) '((1) (2) (3))) #f)
 633
 634 (define (assoc obj list . compare)
 635   (if (null? compare)
 636       (set! compare equal?)
 637       (set! compare (car compare))
 638       )
 639   (if (null? list)
 640       #f
 641     (if (compare obj (caar list))
 642         (car list)
 643         (assoc obj (cdr list) compare)
 644         )
 645     )
 646   )
 647
 648 (define (assq obj list) (assoc obj list eq?))
 649 (define (assv obj list) (assoc obj list eqv?))
 650
 651 (_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1))
 652 (_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2))
 653 (_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3))
 654
 655 (define char? integer?)
 656
 657 (_??_ (char? #\q) #t)
 658 (_??_ (char? "h") #f)
 659
 660 (define (char-upper-case? c) (<= #\A c #\Z))
 661
 662 (_??_ (char-upper-case? #\a) #f)
 663 (_??_ (char-upper-case? #\B) #t)
 664 (_??_ (char-upper-case? #\0) #f)
 665 (_??_ (char-upper-case? #\space) #f)
 666
 667 (define (char-lower-case? c) (<= #\a c #\a))
 668
 669 (_??_ (char-lower-case? #\a) #t)
 670 (_??_ (char-lower-case? #\B) #f)
 671 (_??_ (char-lower-case? #\0) #f)
 672 (_??_ (char-lower-case? #\space) #f)
 673
 674 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
 675
 676 (_??_ (char-alphabetic? #\a) #t)
 677 (_??_ (char-alphabetic? #\B) #t)
 678 (_??_ (char-alphabetic? #\0) #f)
 679 (_??_ (char-alphabetic? #\space) #f)
 680
 681 (define (char-numeric? c) (<= #\0 c #\9))
 682
 683 (_??_ (char-numeric? #\a) #f)
 684 (_??_ (char-numeric? #\B) #f)
 685 (_??_ (char-numeric? #\0) #t)
 686 (_??_ (char-numeric? #\space) #f)
 687
 688 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
 689
 690 (_??_ (char-whitespace? #\a) #f)
 691 (_??_ (char-whitespace? #\B) #f)
 692 (_??_ (char-whitespace? #\0) #f)
 693 (_??_ (char-whitespace? #\space) #t)
 694
 695 (define char->integer (macro (v) v))
 696 (define integer->char char->integer)
 697
 698 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
 699
 700 (_??_ (char-upcase #\a) #\A)
 701 (_??_ (char-upcase #\B) #\B)
 702 (_??_ (char-upcase #\0) #\0)
 703 (_??_ (char-upcase #\space) #\space)
 704
 705 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
 706
 707 (_??_ (char-downcase #\a) #\a)
 708 (_??_ (char-downcase #\B) #\b)
 709 (_??_ (char-downcase #\0) #\0)
 710 (_??_ (char-downcase #\space) #\space)
 711
 712 (define (digit-value c)
 713   (if (char-numeric? c)
 714       (- c #\0)
 715       #f)
 716   )
 717
 718 (_??_ (digit-value #\1) 1)
 719 (_??_ (digit-value #\a) #f)
 720
 721 (define string (lambda chars (list->string chars)))
 722
 723 (_??_ (string #\a #\b #\c) "abc")
 724
 725 (_??_ (apply cons '(a b)) '(a . b))
 726
 727 (define map
 728   (lambda (proc . lists)
 729          (define (_a lists)
 730            (cond ((null? lists) ())
 731                  (else
 732                   (cons (caar lists) (_a (cdr lists)))
 733                   )
 734                  )
 735            )
 736          (define (_n lists)
 737            (cond ((null? lists) ())
 738                  (else
 739                   (cons (cdr (car lists)) (_n (cdr lists)))
 740                   )
 741                  )
 742            )
 743          (define (_m lists)
 744            (cond ((null? (car lists)) ())
 745                  (else
 746                   (cons (apply proc (_a lists)) (_m (_n lists)))
 747                   )
 748                  )
 749            )
 750          (_m lists)
 751          )
 752   )
 753
 754 (_??_ (map cadr '((a b) (d e) (g h))) '(b e h))
 755
 756 (define for-each
 757   (lambda (proc . lists)
 758     (define (_f lists)
 759       (cond ((null? (car lists)) #t)
 760             (else
 761              (apply proc (map car lists))
 762              (_f (map cdr lists))
 763              )
 764             )
 765       )
 766     (_f lists)
 767     )
 768   )
 769
 770 (for-each display '("hello" " " "world" "\n"))
 771
 772 (define (newline) (write-char #\newline))
 773
 774 (newline)
 775
 776 (call-with-current-continuation
 777  (lambda (exit)
 778    (for-each (lambda (x)
 779                (write "test" x)
 780                (if (negative? x)
 781                    (exit x)))
 782              '(54 0 37 -3 245 19))
 783    #t))
 784
 785
 786                                         ; `q -> (quote q)
 787                                         ; `(q) -> (append (quote (q)))
 788                                         ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
 789                                         ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
 790
 791
 792
 793 (_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))
 794
 795
 796 (define repeat
 797   (macro (count . rest)
 798          (define counter '__count__)
 799          (cond ((pair? count)
 800                 (set! counter (car count))
 801                 (set! count (cadr count))
 802                 )
 803                )
 804          `(let ((,counter 0)
 805                 (__max__ ,count)
 806                 )
 807             (while (< ,counter __max__)
 808               ,@rest
 809               (set! ,counter (+ ,counter 1))
 810               )
 811             )
 812          )
 813   )
 814
 815 (repeat 2 (write 'hello))
 816 (repeat (x 3) (write 'goodbye x))
 817
 818 (define case
 819   (macro (test . l)
 820                                         ; construct the body of the
 821                                         ; case, dealing with the
 822                                         ; lambda version ( => lambda)
 823
 824          (define (_unarrow l)
 825            (cond ((null? l) l)
 826                  ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
 827                  (else l))
 828            )
 829
 830                                         ; Build the case elements, which is
 831                                         ; simply a list of cond clauses
 832
 833          (define (_case l)
 834
 835            (cond ((null? l) ())
 836
 837                                         ; else case
 838
 839                  ((eq? (caar l) 'else)
 840                   `((else ,@(_unarrow (cdr (car l))))))
 841
 842                                         ; regular case
 843
 844                  (else
 845                   (cons
 846                    `((eqv? ,(caar l) __key__)
 847                      ,@(_unarrow (cdr (car l))))
 848                    (_case (cdr l)))
 849                   )
 850                  )
 851            )
 852
 853                                         ; now construct the overall
 854                                         ; expression, using a lambda
 855                                         ; to hold the computed value
 856                                         ; of the test expression
 857
 858          `((lambda (__key__)
 859              (cond ,@(_case l))) ,test)
 860          )
 861   )
 862
 863 (_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "one")
 864 (_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "two")
 865 (_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x) "three")) (12 "twelve") (else "else")) "three")
 866 (_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "else")
 867 (_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "twelve")
 868
 869 (define do
 870   (macro (vars test . cmds)
 871     (define (_step v)
 872       (if (null? v)
 873           '()
 874           (if (null? (cddr (car v)))
 875               (_step (cdr v))
 876               (cons `(set! ,(caar v) ,(caddr (car v)))
 877                     (_step (cdr v))
 878                     )
 879               )
 880           )
 881       )
 882     `(let ,(map (lambda (v) (list (car v) (cadr v))) vars)
 883        (while (not ,(car test))
 884               ,@cmds
 885               ,@(_step vars)
 886               )
 887        ,@(cdr test)
 888        )
 889     )
 890   )
 891
 892 (do ((x 1 (+ x 1)))
 893     ((= x 10) "done")
 894   (display "x: ")
 895   (write x)
 896   (newline)
 897   )
 898
 899 (_??_ (do ((vec (make-vector 5))
 900            (i 0 (+ i 1)))
 901           ((= i 5) vec)
 902         (vector-set! vec i i)) #(0 1 2 3 4))